home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume1 / xlisp1.4 / part3 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  62.0 KB
  1. Date: Wed, 13 Mar 85 16:56:41 pst
  2. From: decvax!ucbvax!UCBJADE!ucbjade:mwm (Mike Meyer)
  3. Subject: XLISP 1.4 part 3 (of 4)
  4.  
  5.  
  6. #! /bin/sh
  7. # This is a shell archive, meaning:
  8. # 1. Remove everything above the #! /bin/sh line.
  9. # 2. Save the resulting text in a file.
  10. # 3. Execute the file with /bin/sh (not csh) to create the files:
  11. #    xldmem.c
  12. #    xleval.c
  13. #    xlfio.c
  14. #    xlftab.c
  15. #    xlglob.c
  16. #    xlinit.c
  17. #    xlio.c
  18. #    xlisp.c
  19. #    xljump.c
  20. #    xlmath.c
  21. #    xlprin.c
  22. #    xlread.c
  23. # This archive created: Mon Dec  2 10:17:38 1985
  24. export PATH; PATH=/bin:$PATH
  25. echo shar: extracting "'xldmem.c'" '(6552 characters)'
  26. if test -f 'xldmem.c'
  27. then
  28.     echo shar: will not over-write existing file "'xldmem.c'"
  29. else
  30. sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
  31. /* xldmem - xlisp dynamic memory management routines */
  32.  
  33. #include "xlisp.h"
  34.  
  35. /* useful definitions */
  36. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  37.  
  38. /* external variables */
  39. extern NODE *oblist,*keylist;
  40. extern NODE *xlstack;
  41. extern NODE *xlenv,*xlnewenv;
  42. extern long total;
  43. extern int anodes,nnodes,nsegs,nfree,gccalls;
  44. extern struct segment *segs;
  45. extern NODE *fnodes;
  46.  
  47. /* external procedures */
  48. extern char *malloc();
  49. extern char *calloc();
  50.  
  51. /* newnode - allocate a new node */
  52. NODE *newnode(type)
  53.   int type;
  54. {
  55.     NODE *nnode;
  56.  
  57.     /* get a free node */
  58.     if ((nnode = fnodes) == NIL) {
  59.     gc();
  60.     if ((nnode = fnodes) == NIL)
  61.         xlabort("insufficient node space");
  62.     }
  63.  
  64.     /* unlink the node from the free list */
  65.     fnodes = cdr(nnode);
  66.     nfree -= 1;
  67.  
  68.     /* initialize the new node */
  69.     nnode->n_type = type;
  70.     rplacd(nnode,NIL);
  71.  
  72.     /* return the new node */
  73.     return (nnode);
  74. }
  75.  
  76. /* stralloc - allocate memory for a string adding a byte for the terminator */
  77. char *stralloc(size)
  78.   int size;
  79. {
  80.     char *sptr;
  81.  
  82.     /* allocate memory for the string copy */
  83.     if ((sptr = malloc(size+1)) == NULL) {
  84.     gc();
  85.     if ((sptr = malloc(size+1)) == NULL)
  86.         xlfail("insufficient string space");
  87.     }
  88.     total += (long) (size+1);
  89.  
  90.     /* return the new string memory */
  91.     return (sptr);
  92. }
  93.  
  94. /* strsave - generate a dynamic copy of a string */
  95. char *strsave(str)
  96.   char *str;
  97. {
  98.     char *sptr;
  99.  
  100.     /* create a new string */
  101.     sptr = stralloc(strlen(str));
  102.     strcpy(sptr,str);
  103.  
  104.     /* return the new string */
  105.     return (sptr);
  106. }
  107.  
  108. /* strfree - free string memory */
  109. strfree(str)
  110.   char *str;
  111. {
  112.     total -= (long) (strlen(str)+1);
  113.     free(str);
  114. }
  115.  
  116. /* gc - garbage collect */
  117. gc()
  118. {
  119.     NODE *p;
  120.  
  121.     /* mark all accessible nodes */
  122.     mark(oblist); mark(keylist);
  123.     mark(xlenv);
  124.     mark(xlnewenv);
  125.  
  126.     /* mark the evaluation stack */
  127.     for (p = xlstack; p; p = cdr(p))
  128.     mark(car(p));
  129.  
  130.     /* sweep memory collecting all unmarked nodes */
  131.     sweep();
  132.  
  133.     /* if there's still nothing available, allocate more memory */
  134.     if (fnodes == NIL)
  135.     addseg();
  136.  
  137.     /* count the gc call */
  138.     gccalls++;
  139. }
  140.  
  141. /* mark - mark all accessible nodes */
  142. LOCAL mark(ptr)
  143.   NODE *ptr;
  144. {
  145.     NODE *this,*prev,*tmp;
  146.  
  147.     /* just return on nil */
  148.     if (ptr == NIL)
  149.     return;
  150.  
  151.     /* initialize */
  152.     prev = NIL;
  153.     this = ptr;
  154.  
  155.     /* mark this list */
  156.     while (TRUE) {
  157.  
  158.     /* descend as far as we can */
  159.     while (TRUE) {
  160.  
  161.         /* check for this node being marked */
  162.         if (this->n_flags & MARK)
  163.         break;
  164.  
  165.         /* mark it and its descendants */
  166.         else {
  167.  
  168.         /* mark the node */
  169.         this->n_flags |= MARK;
  170.  
  171.         /* follow the left sublist if there is one */
  172.         if (livecar(this)) {
  173.             this->n_flags |= LEFT;
  174.             tmp = prev;
  175.             prev = this;
  176.             this = car(prev);
  177.             rplaca(prev,tmp);
  178.         }
  179.  
  180.         /* otherwise, follow the right sublist if there is one */
  181.         else if (livecdr(this)) {
  182.             this->n_flags &= ~LEFT;
  183.             tmp = prev;
  184.             prev = this;
  185.             this = cdr(prev);
  186.             rplacd(prev,tmp);
  187.         }
  188.         else
  189.             break;
  190.         }
  191.     }
  192.  
  193.     /* backup to a point where we can continue descending */
  194.     while (TRUE) {
  195.  
  196.         /* check for termination condition */
  197.         if (prev == NIL)
  198.         return;
  199.  
  200.         /* check for coming from the left side */
  201.         if (prev->n_flags & LEFT)
  202.         if (livecdr(prev)) {
  203.             prev->n_flags &= ~LEFT;
  204.             tmp = car(prev);
  205.             rplaca(prev,this);
  206.             this = cdr(prev);
  207.             rplacd(prev,tmp);
  208.             break;
  209.         }
  210.         else {
  211.             tmp = prev;
  212.             prev = car(tmp);
  213.             rplaca(tmp,this);
  214.             this = tmp;
  215.         }
  216.  
  217.         /* otherwise, came from the right side */
  218.         else {
  219.         tmp = prev;
  220.         prev = cdr(tmp);
  221.         rplacd(tmp,this);
  222.         this = tmp;
  223.         }
  224.     }
  225.     }
  226. }
  227.  
  228. /* sweep - sweep all unmarked nodes and add them to the free list */
  229. LOCAL sweep()
  230. {
  231.     struct segment *seg;
  232.     NODE *p;
  233.     int n;
  234.  
  235.     /* empty the free list */
  236.     fnodes = NIL;
  237.     nfree = 0;
  238.  
  239.     /* add all unmarked nodes */
  240.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  241.     p = &seg->sg_nodes[0];
  242.     for (n = seg->sg_size; n--; p++)
  243.         if (!(p->n_flags & MARK)) {
  244.         switch (ntype(p)) {
  245.         case STR:
  246.             if (p->n_strtype == DYNAMIC && p->n_str != NULL)
  247.                 strfree(p->n_str);
  248.             break;
  249.         case FPTR:
  250.             if (p->n_fp)
  251.                 fclose(p->n_fp);
  252.             break;
  253.         }
  254.         p->n_type = FREE;
  255.         p->n_flags = 0;
  256.         rplaca(p,NIL);
  257.         rplacd(p,fnodes);
  258.         fnodes = p;
  259.         nfree++;
  260.         }
  261.         else
  262.         p->n_flags &= ~(MARK | LEFT);
  263.     }
  264. }
  265.  
  266. /* addseg - add a segment to the available memory */
  267. int addseg()
  268. {
  269.     struct segment *newseg;
  270.     NODE *p;
  271.     int n;
  272.  
  273.     /* check for zero allocation */
  274.     if (anodes == 0)
  275.     return (FALSE);
  276.  
  277.     /* allocate a new segment */
  278.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  279.  
  280.     /* initialize the new segment */
  281.     newseg->sg_size = anodes;
  282.     newseg->sg_next = segs;
  283.     segs = newseg;
  284.  
  285.     /* add each new node to the free list */
  286.     p = &newseg->sg_nodes[0];
  287.     for (n = anodes; n--; ) {
  288.         rplacd(p,fnodes);
  289.         fnodes = p++;
  290.     }
  291.  
  292.     /* update the statistics */
  293.     total += (long) ALLOCSIZE;
  294.     nnodes += anodes;
  295.     nfree += anodes;
  296.     nsegs++;
  297.  
  298.     /* return successfully */
  299.     return (TRUE);
  300.     }
  301.     else
  302.     return (FALSE);
  303. }
  304.  
  305. /* livecar - do we need to follow the car? */
  306. LOCAL int livecar(n)
  307.   NODE *n;
  308. {
  309.     switch (ntype(n)) {
  310.     case SUBR:
  311.     case FSUBR:
  312.     case INT:
  313.     case STR:
  314.     case FPTR:
  315.         return (FALSE);
  316.     case SYM:
  317.     case LIST:
  318.     case OBJ:
  319.         return (car(n) != NIL);
  320.     default:
  321.         printf("bad node type (%d) found during left scan\n",ntype(n));
  322.         exit();
  323.     }
  324. }
  325.  
  326. /* livecdr - do we need to follow the cdr? */
  327. LOCAL int livecdr(n)
  328.   NODE *n;
  329. {
  330.     switch (ntype(n)) {
  331.     case SUBR:
  332.     case FSUBR:
  333.     case INT:
  334.     case STR:
  335.     case FPTR:
  336.         return (FALSE);
  337.     case SYM:
  338.     case LIST:
  339.     case OBJ:
  340.         return (cdr(n) != NIL);
  341.     default:
  342.         printf("bad node type (%d) found during right scan\n",ntype(n));
  343.         exit();
  344.     }
  345. }
  346.  
  347. /* stats - print memory statistics */
  348. stats()
  349. {
  350.     printf("Nodes:       %d\n",nnodes);
  351.     printf("Free nodes:  %d\n",nfree);
  352.     printf("Segments:    %d\n",nsegs);
  353.     printf("Allocate:    %d\n",anodes);
  354.     printf("Total:       %ld\n",total);
  355.     printf("Collections: %d\n",gccalls);
  356. }
  357.  
  358. /* xlminit - initialize the dynamic memory module */
  359. xlminit()
  360. {
  361.     /* initialize our internal variables */
  362.     anodes = NNODES;
  363.     total = 0L;
  364.     nnodes = nsegs = nfree = gccalls = 0;
  365.     fnodes = NIL;
  366.     segs = NULL;
  367.  
  368.     /* initialize structures that are marked by the collector */
  369.     xlstack = xlenv = xlnewenv = oblist = keylist = NIL;
  370. }
  371. SHAR_EOF
  372. if test 6552 -ne "`wc -c < 'xldmem.c'`"
  373. then
  374.     echo shar: error transmitting "'xldmem.c'" '(should have been 6552 characters)'
  375. fi
  376. fi # end of overwriting check
  377. echo shar: extracting "'xleval.c'" '(7688 characters)'
  378. if test -f 'xleval.c'
  379. then
  380.     echo shar: will not over-write existing file "'xleval.c'"
  381. else
  382. sed 's/^X//' << \SHAR_EOF > 'xleval.c'
  383. /* xleval - xlisp evaluator */
  384.  
  385. #include "xlisp.h"
  386.  
  387. /* external variables */
  388. extern NODE *xlstack,*xlenv,*xlnewenv;
  389. extern NODE *s_lambda,*s_macro;
  390. extern NODE *k_optional,*k_rest,*k_aux;
  391. extern NODE *s_evalhook,*s_applyhook;
  392. extern NODE *s_unbound;
  393. extern NODE *s_stdout;
  394.  
  395. /* forward declarations */
  396. XFORWARD NODE *xlxeval();
  397. XFORWARD NODE *evalhook();
  398. XFORWARD NODE *evform();
  399. XFORWARD NODE *evsym();
  400. XFORWARD NODE *evfun();
  401.  
  402. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  403. NODE *xleval(expr)
  404.   NODE *expr;
  405. {
  406.     return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
  407. }
  408.  
  409. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  410. NODE *xlxeval(expr)
  411.   NODE *expr;
  412. {
  413.     /* evaluate nil to itself */
  414.     if (expr == NIL)
  415.     return (NIL);
  416.  
  417.     /* add trace entry */
  418.     xltpush(expr);
  419.  
  420.     /* check type of value */
  421.     if (consp(expr))
  422.     expr = evform(expr);
  423.     else if (symbolp(expr))
  424.     expr = evsym(expr);
  425.  
  426.     /* remove trace entry */
  427.     xltpop();
  428.  
  429.     /* return the value */
  430.     return (expr);
  431. }
  432.  
  433. /* xlapply - apply a function to a list of arguments */
  434. NODE *xlapply(fun,args)
  435.   NODE *fun,*args;
  436. {
  437.     NODE *val;
  438.  
  439.     /* check for a null function */
  440.     if (fun == NIL)
  441.     xlfail("bad function");
  442.  
  443.     /* evaluate the function */
  444.     if (subrp(fun))
  445.     val = (*fun->n_subr)(args);
  446.     else if (consp(fun)) {
  447.     if (car(fun) != s_lambda)
  448.         xlfail("bad function type");
  449.     val = evfun(fun,args);
  450.     }
  451.     else
  452.     xlfail("bad function");
  453.  
  454.     /* return the result value */
  455.     return (val);
  456. }
  457.  
  458. /* evform - evaluate a form */
  459. LOCAL NODE *evform(expr)
  460.   NODE *expr;
  461. {
  462.     NODE *oldstk,fun,args,*val,*type;
  463.  
  464.     /* create a stack frame */
  465.     oldstk = xlsave(&fun,&args,NULL);
  466.  
  467.     /* get the function and the argument list */
  468.     fun.n_ptr = car(expr);
  469.     args.n_ptr = cdr(expr);
  470.  
  471.     /* evaluate the first expression */
  472.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NIL)
  473.     xlfail("bad function");
  474.  
  475.     /* evaluate the function */
  476.     if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
  477.     if (subrp(fun.n_ptr))
  478.         args.n_ptr = xlevlist(args.n_ptr);
  479.     val = (*fun.n_ptr->n_subr)(args.n_ptr);
  480.     }
  481.     else if (consp(fun.n_ptr)) {
  482.     if ((type = car(fun.n_ptr)) == s_lambda) {
  483.         args.n_ptr = xlevlist(args.n_ptr);
  484.         val = evfun(fun.n_ptr,args.n_ptr);
  485.     }
  486.     else if (type == s_macro) {
  487.         args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
  488.         val = xleval(args.n_ptr);
  489.     }
  490.     else
  491.         xlfail("bad function type");
  492.     }
  493.     else if (objectp(fun.n_ptr))
  494.     val = xlsend(fun.n_ptr,args.n_ptr);
  495.     else
  496.     xlfail("bad function");
  497.  
  498.     /* restore the previous stack frame */
  499.     xlstack = oldstk;
  500.  
  501.     /* return the result value */
  502.     return (val);
  503. }
  504.  
  505. /* evalhook - call the evalhook function */
  506. LOCAL NODE *evalhook(expr)
  507.   NODE *expr;
  508. {
  509.     NODE *oldstk,*oldenv,fun,args,*val;
  510.  
  511.     /* create a new stack frame */
  512.     oldstk = xlsave(&fun,&args,NULL);
  513.  
  514.     /* get the hook function */
  515.     fun.n_ptr = s_evalhook->n_symvalue;
  516.  
  517.     /* make an argument list */
  518.     args.n_ptr = newnode(LIST);
  519.     rplaca(args.n_ptr,expr);
  520.  
  521.     /* rebind the hook functions to nil */
  522.     oldenv = xlenv;
  523.     xlsbind(s_evalhook,NIL);
  524.     xlsbind(s_applyhook,NIL);
  525.  
  526.     /* call the hook function */
  527.     val = xlapply(fun.n_ptr,args.n_ptr);
  528.  
  529.     /* unbind the symbols */
  530.     xlunbind(oldenv);
  531.  
  532.     /* restore the previous stack frame */
  533.     xlstack = oldstk;
  534.  
  535.     /* return the value */
  536.     return (val);
  537. }
  538.  
  539. /* xlevlist - evaluate a list of arguments */
  540. NODE *xlevlist(args)
  541.   NODE *args;
  542. {
  543.     NODE *oldstk,src,dst,*new,*last,*val;
  544.  
  545.     /* create a stack frame */
  546.     oldstk = xlsave(&src,&dst,NULL);
  547.  
  548.     /* initialize */
  549.     src.n_ptr = args;
  550.  
  551.     /* evaluate each argument */
  552.     for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
  553.  
  554.     /* check this entry */
  555.     if (!consp(src.n_ptr))
  556.         xlfail("bad argument list");
  557.  
  558.     /* allocate a new list entry */
  559.     new = newnode(LIST);
  560.     if (val)
  561.         rplacd(last,new);
  562.     else
  563.         val = dst.n_ptr = new;
  564.     rplaca(new,xleval(car(src.n_ptr)));
  565.     last = new;
  566.     }
  567.  
  568.     /* restore the previous stack frame */
  569.     xlstack = oldstk;
  570.  
  571.     /* return the new list */
  572.     return (val);
  573. }
  574.  
  575. /* evsym - evaluate a symbol */
  576. LOCAL NODE *evsym(sym)
  577.   NODE *sym;
  578. {
  579.     NODE *p;
  580.  
  581.     /* check for a reference to an instance variable */
  582.     if ((p = xlobsym(sym)) != NIL)
  583.     return (car(p));
  584.  
  585.     /* get the value of the variable */
  586.     while ((p = sym->n_symvalue) == s_unbound)
  587.     xlunbound(sym);
  588.  
  589.     /* return the value */
  590.     return (p);
  591. }
  592.  
  593. /* xlunbound - signal an unbound variable error */
  594. xlunbound(sym)
  595.   NODE *sym;
  596. {
  597.     xlcerror("try evaluating symbol again","unbound variable",sym);
  598. }
  599.  
  600. /* evfun - evaluate a function */
  601. LOCAL NODE *evfun(fun,args)
  602.   NODE *fun,*args;
  603. {
  604.     NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
  605.  
  606.     /* create a stack frame */
  607.     oldstk = xlsave(&cptr,NULL);
  608.  
  609.     /* skip the function type */
  610.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  611.     xlfail("bad function definition");
  612.  
  613.     /* get the formal argument list */
  614.     if ((fargs = car(fun)) && !consp(fargs))
  615.     xlfail("bad formal argument list");
  616.  
  617.     /* bind the formal parameters */
  618.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  619.     xlabind(fargs,args);
  620.     xlfixbindings();
  621.  
  622.     /* execute the code */
  623.     for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
  624.     val = xlevarg(&cptr.n_ptr);
  625.  
  626.     /* restore the environment */
  627.     xlunbind(oldenv); xlnewenv = oldnewenv;
  628.  
  629.     /* restore the previous stack frame */
  630.     xlstack = oldstk;
  631.  
  632.     /* return the result value */
  633.     return (val);
  634. }
  635.  
  636. /* xlabind - bind the arguments for a function */
  637. xlabind(fargs,aargs)
  638.   NODE *fargs,*aargs;
  639. {
  640.     NODE *arg;
  641.  
  642.     /* evaluate and bind each required argument */
  643.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  644.  
  645.     /* bind the formal variable to the argument value */
  646.     xlbind(arg,car(aargs));
  647.  
  648.     /* move the argument list pointers ahead */
  649.     fargs = cdr(fargs);
  650.     aargs = cdr(aargs);
  651.     }
  652.  
  653.     /* check for the '&optional' keyword */
  654.     if (consp(fargs) && car(fargs) == k_optional) {
  655.     fargs = cdr(fargs);
  656.  
  657.     /* bind the arguments that were supplied */
  658.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  659.  
  660.         /* bind the formal variable to the argument value */
  661.         xlbind(arg,car(aargs));
  662.  
  663.         /* move the argument list pointers ahead */
  664.         fargs = cdr(fargs);
  665.         aargs = cdr(aargs);
  666.     }
  667.  
  668.     /* bind the rest to nil */
  669.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  670.  
  671.         /* bind the formal variable to nil */
  672.         xlbind(arg,NIL);
  673.  
  674.         /* move the argument list pointer ahead */
  675.         fargs = cdr(fargs);
  676.     }
  677.     }
  678.  
  679.     /* check for the '&rest' keyword */
  680.     if (consp(fargs) && car(fargs) == k_rest) {
  681.     fargs = cdr(fargs);
  682.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  683.         xlbind(arg,aargs);
  684.     else
  685.         xlfail("symbol missing after &rest");
  686.     fargs = cdr(fargs);
  687.     aargs = NIL;
  688.     }
  689.  
  690.     /* check for the '&aux' keyword */
  691.     if (consp(fargs) && car(fargs) == k_aux)
  692.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  693.         xlbind(car(fargs),NIL);
  694.  
  695.     /* make sure the correct number of arguments were supplied */
  696.     if (fargs != aargs)
  697.     xlfail(fargs ? "too few arguments" : "too many arguments");
  698. }
  699.  
  700. /* iskeyword - check to see if a symbol is a keyword */
  701. LOCAL int iskeyword(sym)
  702.   NODE *sym;
  703. {
  704.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  705. }
  706.  
  707. /* xlsave - save nodes on the stack */
  708. NODE *xlsave(n)
  709.   NODE *n;
  710. {
  711.     NODE **nptr,*oldstk;
  712.  
  713.     /* save the old stack pointer */
  714.     oldstk = xlstack;
  715.  
  716.     /* save each node */
  717.     for (nptr = &n; *nptr != NULL; nptr++) {
  718.     rplaca(*nptr,NIL);
  719.     rplacd(*nptr,xlstack);
  720.     xlstack = *nptr;
  721.     }
  722.  
  723.     /* return the old stack pointer */
  724.     return (oldstk);
  725. }
  726. SHAR_EOF
  727. if test 7688 -ne "`wc -c < 'xleval.c'`"
  728. then
  729.     echo shar: error transmitting "'xleval.c'" '(should have been 7688 characters)'
  730. fi
  731. fi # end of overwriting check
  732. echo shar: extracting "'xlfio.c'" '(8960 characters)'
  733. if test -f 'xlfio.c'
  734. then
  735.     echo shar: will not over-write existing file "'xlfio.c'"
  736. else
  737. sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
  738. /* xlfio.c - xlisp file i/o */
  739.  
  740. #include "xlisp.h"
  741. #include "ctype.h"
  742.  
  743. /* external variables */
  744. extern NODE *s_stdin,*s_stdout;
  745. extern NODE *xlstack;
  746. extern int xlfsize;
  747. extern char buf[];
  748.  
  749. /* external routines */
  750. extern FILE *fopen();
  751.  
  752. /* forward declarations */
  753. XFORWARD NODE *printit();
  754. XFORWARD NODE *flatsize();
  755. XFORWARD NODE *explode();
  756. XFORWARD NODE *implode();
  757. XFORWARD NODE *openit();
  758. XFORWARD NODE *getfile();
  759.  
  760. /* xread - read an expression */
  761. NODE *xread(args)
  762.   NODE *args;
  763. {
  764.     NODE *oldstk,fptr,eof,*val;
  765.  
  766.     /* create a new stack frame */
  767.     oldstk = xlsave(&fptr,&eof,NULL);
  768.  
  769.     /* get file pointer and eof value */
  770.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  771.     eof.n_ptr = (args ? xlarg(&args) : NIL);
  772.     xllastarg(args);
  773.  
  774.     /* read an expression */
  775.     if (!xlread(fptr.n_ptr,&val))
  776.     val = eof.n_ptr;
  777.  
  778.     /* restore the previous stack frame */
  779.     xlstack = oldstk;
  780.  
  781.     /* return the expression */
  782.     return (val);
  783. }
  784.  
  785. /* xprint - builtin function 'print' */
  786. NODE *xprint(args)
  787.   NODE *args;
  788. {
  789.     return (printit(args,TRUE,TRUE));
  790. }
  791.  
  792. /* xprin1 - builtin function 'prin1' */
  793. NODE *xprin1(args)
  794.   NODE *args;
  795. {
  796.     return (printit(args,TRUE,FALSE));
  797. }
  798.  
  799. /* xprinc - builtin function princ */
  800. NODE *xprinc(args)
  801.   NODE *args;
  802. {
  803.     return (printit(args,FALSE,FALSE));
  804. }
  805.  
  806. /* xterpri - terminate the current print line */
  807. NODE *xterpri(args)
  808.   NODE *args;
  809. {
  810.     NODE *fptr;
  811.  
  812.     /* get file pointer */
  813.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  814.     xllastarg(args);
  815.  
  816.     /* terminate the print line and return nil */
  817.     xlterpri(fptr);
  818.     return (NIL);
  819. }
  820.  
  821. /* printit - common print function */
  822. LOCAL NODE *printit(args,pflag,tflag)
  823.   NODE *args; int pflag,tflag;
  824. {
  825.     NODE *oldstk,fptr,val;
  826.  
  827.     /* create a new stack frame */
  828.     oldstk = xlsave(&fptr,&val,NULL);
  829.  
  830.     /* get expression to print and file pointer */
  831.     val.n_ptr = xlarg(&args);
  832.     fptr.n_ptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  833.     xllastarg(args);
  834.  
  835.     /* print the value */
  836.     xlprint(fptr.n_ptr,val.n_ptr,pflag);
  837.  
  838.     /* terminate the print line if necessary */
  839.     if (tflag)
  840.     xlterpri(fptr.n_ptr);
  841.  
  842.     /* restore the previous stack frame */
  843.     xlstack = oldstk;
  844.  
  845.     /* return the result */
  846.     return (val.n_ptr);
  847. }
  848.  
  849. /* xflatsize - compute the size of a printed representation using prin1 */
  850. NODE *xflatsize(args)
  851.   NODE *args;
  852. {
  853.     return (flatsize(args,TRUE));
  854. }
  855.  
  856. /* xflatc - compute the size of a printed representation using princ */
  857. NODE *xflatc(args)
  858.   NODE *args;
  859. {
  860.     return (flatsize(args,FALSE));
  861. }
  862.  
  863. /* flatsize - compute the size of a printed expression */
  864. LOCAL NODE *flatsize(args,pflag)
  865.   NODE *args; int pflag;
  866. {
  867.     NODE *oldstk,val;
  868.  
  869.     /* create a new stack frame */
  870.     oldstk = xlsave(&val,NULL);
  871.  
  872.     /* get the expression */
  873.     val.n_ptr = xlarg(&args);
  874.     xllastarg(args);
  875.  
  876.     /* print the value to compute its size */
  877.     xlfsize = 0;
  878.     xlprint(NIL,val.n_ptr,pflag);
  879.  
  880.     /* restore the previous stack frame */
  881.     xlstack = oldstk;
  882.  
  883.     /* return the length of the expression */
  884.     val.n_ptr = newnode(INT);
  885.     val.n_ptr->n_int = xlfsize;
  886.     return (val.n_ptr);
  887. }
  888.  
  889. /* xexplode - explode an expression */
  890. NODE *xexplode(args)
  891.   NODE *args;
  892. {
  893.     return (explode(args,TRUE));
  894. }
  895.  
  896. /* xexplc - explode an expression using princ */
  897. NODE *xexplc(args)
  898.   NODE *args;
  899. {
  900.     return (explode(args,FALSE));
  901. }
  902.  
  903. /* explode - internal explode routine */
  904. LOCAL NODE *explode(args,pflag)
  905.   NODE *args; int pflag;
  906. {
  907.     NODE *oldstk,val,strm;
  908.  
  909.     /* create a new stack frame */
  910.     oldstk = xlsave(&val,&strm,NULL);
  911.  
  912.     /* get the expression */
  913.     val.n_ptr = xlarg(&args);
  914.     xllastarg(args);
  915.  
  916.     /* create a stream */
  917.     strm.n_ptr = newnode(LIST);
  918.  
  919.     /* print the value into the stream */
  920.     xlprint(strm.n_ptr,val.n_ptr,pflag);
  921.  
  922.     /* restore the previous stack frame */
  923.     xlstack = oldstk;
  924.  
  925.     /* return the list of characters */
  926.     return (car(strm.n_ptr));
  927. }
  928.  
  929. /* ximplode - implode a list of characters into a symbol */
  930. NODE *ximplode(args)
  931.   NODE *args;
  932. {
  933.     return (implode(args,TRUE));
  934. }
  935.  
  936. /* xmaknam - implode a list of characters into an uninterned symbol */
  937. NODE *xmaknam(args)
  938.   NODE *args;
  939. {
  940.     return (implode(args,FALSE));
  941. }
  942.  
  943. /* implode - internal implode routine */
  944. LOCAL NODE *implode(args,intflag)
  945.   NODE *args; int intflag;
  946. {
  947.     NODE *list,*val;
  948.     char *p;
  949.  
  950.     /* get the list */
  951.     list = xlarg(&args);
  952.     xllastarg(args);
  953.  
  954.     /* assemble the symbol's pname */
  955.     for (p = buf; consp(list); list = cdr(list)) {
  956.     if ((val = car(list)) == NIL || !fixp(val))
  957.         xlfail("bad character list");
  958.     if ((int)(p - buf) < STRMAX)
  959.         *p++ = val->n_int;
  960.     }
  961.     *p = 0;
  962.  
  963.     /* create a symbol */
  964.     val = (intflag ? xlenter(buf,DYNAMIC) : xlmakesym(buf,DYNAMIC));
  965.  
  966.     /* return the symbol */
  967.     return (val);
  968. }
  969.  
  970. /* xopeni - open an input file */
  971. NODE *xopeni(args)
  972.   NODE *args;
  973. {
  974.     return (openit(args,"r"));
  975. }
  976.  
  977. /* xopeno - open an output file */
  978. NODE *xopeno(args)
  979.   NODE *args;
  980. {
  981.     return (openit(args,"w"));
  982. }
  983.  
  984. /* openit - common file open routine */
  985. LOCAL NODE *openit(args,mode)
  986.   NODE *args; char *mode;
  987. {
  988.     NODE *fname,*val;
  989.     FILE *fp;
  990.  
  991.     /* get the file name */
  992.     fname = xlmatch(STR,&args);
  993.     xllastarg(args);
  994.  
  995.     /* try to open the file */
  996.     if ((fp = fopen(fname->n_str,mode)) != NULL) {
  997.     val = newnode(FPTR);
  998.     val->n_fp = fp;
  999.     val->n_savech = 0;
  1000.     }
  1001.     else
  1002.     val = NIL;
  1003.  
  1004.     /* return the file pointer */
  1005.     return (val);
  1006. }
  1007.  
  1008. /* xclose - close a file */
  1009. NODE *xclose(args)
  1010.   NODE *args;
  1011. {
  1012.     NODE *fptr;
  1013.  
  1014.     /* get file pointer */
  1015.     fptr = xlmatch(FPTR,&args);
  1016.     xllastarg(args);
  1017.  
  1018.     /* make sure the file exists */
  1019.     if (fptr->n_fp == NULL)
  1020.     xlfail("file not open");
  1021.  
  1022.     /* close the file */
  1023.     fclose(fptr->n_fp);
  1024.     fptr->n_fp = NULL;
  1025.  
  1026.     /* return nil */
  1027.     return (NIL);
  1028. }
  1029.  
  1030. /* xrdchar - read a character from a file */
  1031. NODE *xrdchar(args)
  1032.   NODE *args;
  1033. {
  1034.     NODE *fptr,*val;
  1035.     int ch;
  1036.  
  1037.     /* get file pointer */
  1038.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  1039.     xllastarg(args);
  1040.  
  1041.     /* get character and check for eof */
  1042.     if ((ch = xlgetc(fptr)) == EOF)
  1043.     val = NIL;
  1044.     else {
  1045.     val = newnode(INT);
  1046.     val->n_int = ch;
  1047.     }
  1048.  
  1049.     /* return the character */
  1050.     return (val);
  1051. }
  1052.  
  1053. /* xpkchar - peek at a character from a file */
  1054. NODE *xpkchar(args)
  1055.   NODE *args;
  1056. {
  1057.     NODE *flag,*fptr,*val;
  1058.     int ch;
  1059.  
  1060.     /* peek flag and get file pointer */
  1061.     flag = (args ? xlarg(&args) : NIL);
  1062.     fptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  1063.     xllastarg(args);
  1064.  
  1065.     /* skip leading white space and get a character */
  1066.     if (flag)
  1067.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  1068.         xlgetc(fptr);
  1069.     else
  1070.     ch = xlpeek(fptr);
  1071.  
  1072.     /* check for eof */
  1073.     if (ch == EOF)
  1074.     val = NIL;
  1075.     else {
  1076.     val = newnode(INT);
  1077.     val->n_int = ch;
  1078.     }
  1079.  
  1080.     /* return the character */
  1081.     return (val);
  1082. }
  1083.  
  1084. /* xwrchar - write a character to a file */
  1085. NODE *xwrchar(args)
  1086.   NODE *args;
  1087. {
  1088.     NODE *fptr,*chr;
  1089.  
  1090.     /* get the character and file pointer */
  1091.     chr = xlmatch(INT,&args);
  1092.     fptr = (args ? getfile(&args) : s_stdout->n_symvalue);
  1093.     xllastarg(args);
  1094.  
  1095.     /* put character to the file */
  1096.     xlputc(fptr,chr->n_int);
  1097.  
  1098.     /* return the character */
  1099.     return (chr);
  1100. }
  1101.  
  1102. /* xreadline - read a line from a file */
  1103. NODE *xreadline(args)
  1104.   NODE *args;
  1105. {
  1106.     NODE *oldstk,fptr,str;
  1107.     char *p,*sptr;
  1108.     int len,ch;
  1109.  
  1110.     /* create a new stack frame */
  1111.     oldstk = xlsave(&fptr,&str,NULL);
  1112.  
  1113.     /* get file pointer */
  1114.     fptr.n_ptr = (args ? getfile(&args) : s_stdin->n_symvalue);
  1115.     xllastarg(args);
  1116.  
  1117.     /* make a string node */
  1118.     str.n_ptr = newnode(STR);
  1119.     str.n_ptr->n_strtype = DYNAMIC;
  1120.  
  1121.     /* get character and check for eof */
  1122.     len = 0; p = buf;
  1123.     while ((ch = xlgetc(fptr.n_ptr)) != EOF && ch != '\n') {
  1124.  
  1125.     /* check for buffer overflow */
  1126.     if ((int)(p - buf) == STRMAX) {
  1127.         *p = 0;
  1128.          sptr = stralloc(len + STRMAX); *sptr = 0;
  1129.         if (len) {
  1130.         strcpy(sptr,str.n_ptr->n_str);
  1131.         strfree(str.n_ptr->n_str);
  1132.         }
  1133.         str.n_ptr->n_str = sptr;
  1134.         strcat(sptr,buf);
  1135.         len += STRMAX;
  1136.         p = buf;
  1137.     }
  1138.  
  1139.     /* store the character */
  1140.     *p++ = ch;
  1141.     }
  1142.  
  1143.     /* check for end of file */
  1144.     if (len == 0 && p == buf && ch == EOF) {
  1145.     xlstack = oldstk;
  1146.     return (NIL);
  1147.     }
  1148.  
  1149.     /* append the last substring */
  1150.     *p = 0;
  1151.     sptr = stralloc(len + (int)(p - buf)); *sptr = 0;
  1152.     if (len) {
  1153.     strcpy(sptr,str.n_ptr->n_str);
  1154.     strfree(str.n_ptr->n_str);
  1155.     }
  1156.     str.n_ptr->n_str = sptr;
  1157.     strcat(sptr,buf);
  1158.  
  1159.     /* restore the previous stack frame */
  1160.     xlstack = oldstk;
  1161.  
  1162.     /* return the string */
  1163.     return (str.n_ptr);
  1164. }
  1165.  
  1166. /* getfile - get a file or stream */
  1167. LOCAL NODE *getfile(pargs)
  1168.   NODE **pargs;
  1169. {
  1170.     NODE *arg;
  1171.  
  1172.     /* get a file or stream (cons) or nil */
  1173.     if (arg = xlarg(pargs)) {
  1174.     if (filep(arg)) {
  1175.         if (arg->n_fp == NULL)
  1176.         xlfail("file not open");
  1177.     }
  1178.     else if (!consp(arg))
  1179.         xlfail("bad argument type");
  1180.     }
  1181.     return (arg);
  1182. }
  1183. SHAR_EOF
  1184. if test 8960 -ne "`wc -c < 'xlfio.c'`"
  1185. then
  1186.     echo shar: error transmitting "'xlfio.c'" '(should have been 8960 characters)'
  1187. fi
  1188. fi # end of overwriting check
  1189. echo shar: extracting "'xlftab.c'" '(5998 characters)'
  1190. if test -f 'xlftab.c'
  1191. then
  1192.     echo shar: will not over-write existing file "'xlftab.c'"
  1193. else
  1194. sed 's/^X//' << \SHAR_EOF > 'xlftab.c'
  1195. /* xlftab.c - xlisp function table */
  1196.  
  1197. #include "xlisp.h"
  1198.  
  1199. /* external functions */
  1200. extern NODE
  1201.     *xeval(),*xapply(),*xfuncall(),*xquote(),*xbquote(),
  1202.     *xset(),*xsetq(),*xsetf(),*xdefun(),*xdefmacro(),
  1203.     *xgensym(),*xmakesymbol(),*xintern(),
  1204.     *xsymname(),*xsymvalue(),*xsymplist(),*xget(),*xremprop(),
  1205.     *xcar(),*xcaar(),*xcadr(),*xcdr(),*xcdar(),*xcddr(),
  1206.     *xcons(),*xlist(),*xappend(),*xreverse(),*xlast(),*xnth(),*xnthcdr(),
  1207.     *xmember(),*xassoc(),*xsubst(),*xsublis(),*xremove(),*xlength(),
  1208.     *xmapc(),*xmapcar(),*xmapl(),*xmaplist(),
  1209.     *xrplca(),*xrplcd(),*xnconc(),*xdelete(),
  1210.     *xatom(),*xsymbolp(),*xnumberp(),*xboundp(),*xnull(),*xlistp(),*xconsp(),
  1211.     *xeq(),*xeql(),*xequal(),
  1212.     *xcond(),*xand(),*xor(),*xlet(),*xletstar(),*xif(),
  1213.     *xprog(),*xprogstar(),*xprog1(),*xprog2(),*xprogn(),*xgo(),*xreturn(),
  1214.     *xcatch(),*xthrow(),
  1215.     *xerror(),*xcerror(),*xbreak(),*xerrset(),*xbaktrace(),*xevalhook(),
  1216.     *xdo(),*xdostar(),*xdolist(),*xdotimes(),
  1217.     *xadd(),*xsub(),*xmul(),*xdiv(),*xrem(),*xmin(),*xmax(),*xabs(),
  1218.     *xadd1(),*xsub1(),*xbitand(),*xbitior(),*xbitxor(),*xbitnot(),
  1219.     *xminusp(),*xzerop(),*xplusp(),*xevenp(),*xoddp(),
  1220.     *xlss(),*xleq(),*xequ(),*xneq(),*xgeq(),*xgtr(),
  1221.     *xstrlen(),*xstrcat(),*xsubstr(),*xascii(),*xchr(),*xatoi(),*xitoa(),
  1222.     *xread(),*xprint(),*xprin1(),*xprinc(),*xterpri(),
  1223.     *xflatsize(),*xflatc(),*xexplode(),*xexplc(),*ximplode(),*xmaknam(),
  1224.     *xopeni(),*xopeno(),*xclose(),*xrdchar(),*xpkchar(),*xwrchar(),*xreadline(),
  1225.     *xload(),*xgc(),*xexpand(),*xalloc(),*xmem(),*xtype(),*xexit();
  1226.  
  1227. /* the function table */
  1228. struct fdef ftab[] = {
  1229.  
  1230.     /* evaluator functions */
  1231. {    "eval",        SUBR,    xeval        },
  1232. {    "apply",    SUBR,    xapply        },
  1233. {    "funcall",    SUBR,    xfuncall    },
  1234. {    "quote",    FSUBR,    xquote        },
  1235. {    "function",    FSUBR,    xquote        },
  1236. {    "backquote",    FSUBR,    xbquote        },
  1237.  
  1238.     /* symbol functions */
  1239. {    "set",        SUBR,    xset        },
  1240. {    "setq",        FSUBR,    xsetq        },
  1241. {    "setf",        FSUBR,    xsetf        },
  1242. {    "defun",    FSUBR,    xdefun        },
  1243. {    "defmacro",    FSUBR,    xdefmacro    },
  1244. {    "gensym",    SUBR,    xgensym        },
  1245. {    "make-symbol",    SUBR,    xmakesymbol    },
  1246. {    "intern",    SUBR,    xintern        },
  1247. {    "symbol-name",    SUBR,    xsymname    },
  1248. {    "symbol-value",    SUBR,    xsymvalue    },
  1249. {    "symbol-plist",    SUBR,    xsymplist    },
  1250. {    "get",        SUBR,    xget        },
  1251. {    "remprop",    SUBR,    xremprop    },
  1252.  
  1253.     /* list functions */
  1254. {    "car",        SUBR,    xcar        },
  1255. {    "caar",        SUBR,    xcaar        },
  1256. {    "cadr",        SUBR,    xcadr        },
  1257. {    "cdr",        SUBR,    xcdr        },
  1258. {    "cdar",        SUBR,    xcdar        },
  1259. {    "cddr",        SUBR,    xcddr        },
  1260. {    "cons",        SUBR,    xcons        },
  1261. {    "list",        SUBR,    xlist        },
  1262. {    "append",    SUBR,    xappend        },
  1263. {    "reverse",    SUBR,    xreverse    },
  1264. {    "last",        SUBR,    xlast        },
  1265. {    "nth",        SUBR,    xnth        },
  1266. {    "nthcdr",    SUBR,    xnthcdr        },
  1267. {    "member",    SUBR,    xmember        },
  1268. {    "assoc",    SUBR,    xassoc        },
  1269. {    "subst",    SUBR,    xsubst        },
  1270. {    "sublis",    SUBR,    xsublis        },
  1271. {    "remove",    SUBR,    xremove        },
  1272. {    "length",    SUBR,    xlength        },
  1273. {    "mapc",        SUBR,    xmapc        },
  1274. {    "mapcar",    SUBR,    xmapcar        },
  1275. {    "mapl",        SUBR,    xmapl        },
  1276. {    "maplist",    SUBR,    xmaplist    },
  1277.  
  1278.     /* destructive list functions */
  1279. {    "rplaca",    SUBR,    xrplca        },
  1280. {    "rplacd",    SUBR,    xrplcd        },
  1281. {    "nconc",    SUBR,    xnconc        },
  1282. {    "delete",    SUBR,    xdelete        },
  1283.  
  1284.     /* predicate functions */
  1285. {    "atom",        SUBR,    xatom        },
  1286. {    "symbolp",    SUBR,    xsymbolp    },
  1287. {    "numberp",    SUBR,    xnumberp    },
  1288. {    "boundp",    SUBR,    xboundp        },
  1289. {    "null",        SUBR,    xnull        },
  1290. {    "not",        SUBR,    xnull        },
  1291. {    "listp",    SUBR,    xlistp        },
  1292. {    "consp",    SUBR,    xconsp        },
  1293. {    "minusp",    SUBR,    xminusp        },
  1294. {    "zerop",    SUBR,    xzerop        },
  1295. {    "plusp",    SUBR,    xplusp        },
  1296. {    "evenp",    SUBR,    xevenp        },
  1297. {    "oddp",        SUBR,    xoddp        },
  1298. {    "eq",        SUBR,    xeq        },
  1299. {    "eql",        SUBR,    xeql        },
  1300. {    "equal",    SUBR,    xequal        },
  1301.  
  1302.     /* control functions */
  1303. {    "cond",        FSUBR,    xcond        },
  1304. {    "and",        FSUBR,    xand        },
  1305. {    "or",        FSUBR,    xor        },
  1306. {    "let",        FSUBR,    xlet        },
  1307. {    "let*",        FSUBR,    xletstar    },
  1308. {    "if",        FSUBR,    xif        },
  1309. {    "prog",        FSUBR,    xprog        },
  1310. {    "prog*",    FSUBR,    xprogstar    },
  1311. {    "prog1",    FSUBR,    xprog1        },
  1312. {    "prog2",    FSUBR,    xprog2        },
  1313. {    "progn",    FSUBR,    xprogn        },
  1314. {    "go",        FSUBR,    xgo        },
  1315. {    "return",    SUBR,    xreturn        },
  1316. {    "do",        FSUBR,    xdo        },
  1317. {    "do*",        FSUBR,    xdostar        },
  1318. {    "dolist",    FSUBR,    xdolist        },
  1319. {    "dotimes",    FSUBR,    xdotimes    },
  1320. {    "catch",    FSUBR,    xcatch        },
  1321. {    "throw",    SUBR,    xthrow        },
  1322.  
  1323.     /* debugging and error handling functions */
  1324. {    "error",    SUBR,    xerror        },
  1325. {    "cerror",    SUBR,    xcerror        },
  1326. {    "break",    SUBR,    xbreak        },
  1327. {    "errset",    FSUBR,    xerrset        },
  1328. {    "baktrace",    SUBR,    xbaktrace    },
  1329. {    "evalhook",    SUBR,    xevalhook    },
  1330.  
  1331.     /* arithmetic functions */
  1332. {    "+",        SUBR,    xadd        },
  1333. {    "-",        SUBR,    xsub        },
  1334. {    "*",        SUBR,    xmul        },
  1335. {    "/",        SUBR,    xdiv        },
  1336. {    "1+",        SUBR,    xadd1        },
  1337. {    "1-",        SUBR,    xsub1        },
  1338. {    "rem",        SUBR,    xrem        },
  1339. {    "min",        SUBR,    xmin        },
  1340. {    "max",        SUBR,    xmax        },
  1341. {    "abs",        SUBR,    xabs        },
  1342.  
  1343.     /* bitwise logical functions */
  1344. {    "bit-and",    SUBR,    xbitand        },
  1345. {    "bit-ior",    SUBR,    xbitior        },
  1346. {    "bit-xor",    SUBR,    xbitxor        },
  1347. {    "bit-not",    SUBR,    xbitnot        },
  1348.  
  1349.     /* numeric comparison functions */
  1350. {    "<",        SUBR,    xlss        },
  1351. {    "<=",        SUBR,    xleq        },
  1352. {    "=",        SUBR,    xequ        },
  1353. {    "/=",        SUBR,    xneq        },
  1354. {    ">=",        SUBR,    xgeq        },
  1355. {    ">",        SUBR,    xgtr        },
  1356.  
  1357.     /* string functions */
  1358. {    "strlen",    SUBR,    xstrlen        },
  1359. {    "strcat",    SUBR,    xstrcat        },
  1360. {    "substr",    SUBR,    xsubstr        },
  1361. {    "ascii",    SUBR,    xascii        },
  1362. {    "chr",        SUBR,    xchr        },
  1363. {    "atoi",        SUBR,    xatoi        },
  1364. {    "itoa",        SUBR,    xitoa        },
  1365.  
  1366.     /* I/O functions */
  1367. {    "read",        SUBR,    xread        },
  1368. {    "print",    SUBR,    xprint        },
  1369. {    "prin1",    SUBR,    xprin1        },
  1370. {    "princ",    SUBR,    xprinc        },
  1371. {    "terpri",    SUBR,    xterpri        },
  1372. {    "flatsize",    SUBR,    xflatsize    },
  1373. {    "flatc",    SUBR,    xflatc        },
  1374. {    "explode",    SUBR,    xexplode    },
  1375. {    "explodec",    SUBR,    xexplc        },
  1376. {    "implode",    SUBR,    ximplode    },
  1377. {    "maknam",    SUBR,    xmaknam        },
  1378.  
  1379.     /* file I/O functions */
  1380. {    "openi",    SUBR,    xopeni        },
  1381. {    "openo",    SUBR,    xopeno        },
  1382. {    "close",    SUBR,    xclose        },
  1383. {    "read-char",    SUBR,    xrdchar        },
  1384. {    "peek-char",    SUBR,    xpkchar        },
  1385. {    "write-char",    SUBR,    xwrchar        },
  1386. {    "readline",    SUBR,    xreadline    },
  1387.  
  1388.     /* system functions */
  1389. {    "load",        SUBR,    xload        },
  1390. {    "gc",        SUBR,    xgc        },
  1391. {    "expand",    SUBR,    xexpand        },
  1392. {    "alloc",    SUBR,    xalloc        },
  1393. {    "mem",        SUBR,    xmem        },
  1394. {    "type",        SUBR,    xtype        },
  1395. {    "exit",        SUBR,    xexit        },
  1396.  
  1397. {    0                    }
  1398. };
  1399. SHAR_EOF
  1400. if test 5998 -ne "`wc -c < 'xlftab.c'`"
  1401. then
  1402.     echo shar: error transmitting "'xlftab.c'" '(should have been 5998 characters)'
  1403. fi
  1404. fi # end of overwriting check
  1405. echo shar: extracting "'xlglob.c'" '(2114 characters)'
  1406. if test -f 'xlglob.c'
  1407. then
  1408.     echo shar: will not over-write existing file "'xlglob.c'"
  1409. else
  1410. sed 's/^X//' << \SHAR_EOF > 'xlglob.c'
  1411. /* xlglobals - xlisp global variables */
  1412.  
  1413. #include "xlisp.h"
  1414.  
  1415. /* symbols */
  1416. NODE *true = NIL;
  1417. NODE *s_quote = NIL, *s_function = NIL;
  1418. NODE *s_bquote = NIL, *s_comma = NIL, *s_comat = NIL;
  1419. NODE *s_evalhook = NIL, *s_applyhook = NIL;
  1420. NODE *s_lambda = NIL, *s_macro = NIL;
  1421. NODE *s_stdin = NIL, *s_stdout = NIL;
  1422. NODE *s_tracenable = NIL, *s_tlimit = NIL, *s_breakenable = NIL;
  1423. NODE *s_continue = NIL, *s_quit = NIL;
  1424. NODE *s_car = NIL, *s_cdr = NIL;
  1425. NODE *s_get = NIL, *s_svalue = NIL, *s_splist = NIL;
  1426. NODE *s_eql = NIL, *k_test = NIL, *k_tnot = NIL;
  1427. NODE *k_optional = NIL, *k_rest = NIL, *k_aux = NIL;
  1428. NODE *a_subr = NIL, *a_fsubr = NIL;
  1429. NODE *a_list = NIL, *a_sym = NIL, *a_int = NIL;
  1430. NODE *a_str = NIL, *a_obj = NIL, *a_fptr = NIL;
  1431. NODE *oblist = NIL, *keylist = NIL, *s_unbound = NIL;
  1432.  
  1433. /* evaluation variables */
  1434. NODE *xlstack = NIL;
  1435. NODE *xlenv = NIL;
  1436. NODE *xlnewenv = NIL;
  1437.  
  1438. /* exception handling variables */
  1439. CONTEXT *xlcontext = NULL;    /* current exception handler */
  1440. NODE *xlvalue = NIL;        /* exception value */
  1441.  
  1442. /* debugging variables */
  1443. int xldebug = 0;        /* debug level */
  1444. int xltrace = -1;        /* trace stack pointer */
  1445. NODE **trace_stack = NULL;    /* trace stack */
  1446.  
  1447. /* gensym variables */
  1448. char gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
  1449. int gsnumber = 1;        /* gensym number */
  1450.  
  1451. /* i/o variables */
  1452. int xlplevel = 0;        /* prompt nesting level */
  1453. int xlfsize = 0;        /* flat size of current print call */
  1454. int prompt = TRUE;        /* input prompt flag */
  1455.  
  1456. /* dynamic memory variables */
  1457. long total = 0L;        /* total memory in use */
  1458. int anodes = 0;            /* number of nodes to allocate */
  1459. int nnodes = 0;            /* number of nodes allocated */
  1460. int nsegs = 0;            /* number of segments allocated */
  1461. int nfree = 0;            /* number of nodes free */
  1462. int gccalls = 0;        /* number of gc calls */
  1463. struct segment *segs = NULL;    /* list of allocated segments */
  1464. NODE *fnodes = NIL;        /* list of free nodes */
  1465.  
  1466. /* object programming variables */
  1467. NODE *self = NIL, *class = NIL, *object = NIL;
  1468. NODE *new = NIL, *isnew = NIL, *msgcls = NIL, *msgclass = NIL;
  1469. int varcnt = 0;
  1470.  
  1471. /* general purpose string buffer */
  1472. char buf[STRMAX+1] = { 0 };
  1473. SHAR_EOF
  1474. if test 2114 -ne "`wc -c < 'xlglob.c'`"
  1475. then
  1476.     echo shar: error transmitting "'xlglob.c'" '(should have been 2114 characters)'
  1477. fi
  1478. fi # end of overwriting check
  1479. echo shar: extracting "'xlinit.c'" '(3268 characters)'
  1480. if test -f 'xlinit.c'
  1481. then
  1482.     echo shar: will not over-write existing file "'xlinit.c'"
  1483. else
  1484. sed 's/^X//' << \SHAR_EOF > 'xlinit.c'
  1485. /* xlinit.c - xlisp initialization module */
  1486.  
  1487. #include "xlisp.h"
  1488.  
  1489. /* external variables */
  1490. extern NODE *true;
  1491. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  1492. extern NODE *s_lambda,*s_macro;
  1493. extern NODE *s_stdin,*s_stdout;
  1494. extern NODE *s_evalhook,*s_applyhook;
  1495. extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
  1496. extern NODE *s_continue,*s_quit;
  1497. extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist,*s_eql;
  1498. extern NODE *k_test,*k_tnot,*k_optional,*k_rest,*k_aux;
  1499. extern NODE *a_subr,*a_fsubr;
  1500. extern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
  1501. extern struct fdef ftab[];
  1502.  
  1503. /* xlinit - xlisp initialization routine */
  1504. xlinit()
  1505. {
  1506.     struct fdef *fptr;
  1507.     NODE *sym;
  1508.  
  1509.     /* initialize xlisp (must be in this order) */
  1510.     xlminit();    /* initialize xldmem.c */
  1511.     xlsinit();    /* initialize xlsym.c */
  1512.     xldinit();    /* initialize xldbug.c */
  1513.     xloinit();    /* initialize xlobj.c */
  1514.  
  1515.     /* enter the builtin functions */
  1516.     for (fptr = ftab; fptr->f_name; fptr++)
  1517.     xlsubr(fptr->f_name,fptr->f_type,fptr->f_fcn);
  1518.  
  1519.     /* enter the 't' symbol */
  1520.     true = xlsenter("t");
  1521.     true->n_symvalue = true;
  1522.  
  1523.     /* enter some important symbols */
  1524.     s_quote    = xlsenter("quote");
  1525.     s_function    = xlsenter("function");
  1526.     s_bquote    = xlsenter("backquote");
  1527.     s_comma    = xlsenter("comma");
  1528.     s_comat    = xlsenter("comma-at");
  1529.     s_lambda    = xlsenter("lambda");
  1530.     s_macro    = xlsenter("macro");
  1531.     s_eql    = xlsenter("eql");
  1532.     s_continue    = xlsenter("continue");
  1533.     s_quit    = xlsenter("quit");
  1534.  
  1535.     /* enter setf place specifiers */
  1536.     s_car    = xlsenter("car");
  1537.     s_cdr    = xlsenter("cdr");
  1538.     s_get    = xlsenter("get");
  1539.     s_svalue    = xlsenter("symbol-value");
  1540.     s_splist    = xlsenter("symbol-plist");
  1541.  
  1542.     /* enter parameter list keywords */
  1543.     k_test    = xlsenter(":test");
  1544.     k_tnot    = xlsenter(":test-not");
  1545.  
  1546.     /* enter lambda list keywords */
  1547.     k_optional    = xlsenter("&optional");
  1548.     k_rest    = xlsenter("&rest");
  1549.     k_aux    = xlsenter("&aux");
  1550.  
  1551.     /* enter *standard-input* and *standard-output* */
  1552.     s_stdin = xlsenter("*standard-input*");
  1553.     s_stdin->n_symvalue = newnode(FPTR);
  1554.     s_stdin->n_symvalue->n_fp = stdin;
  1555.     s_stdin->n_symvalue->n_savech = 0;
  1556.     s_stdout = xlsenter("*standard-output*");
  1557.     s_stdout->n_symvalue = newnode(FPTR);
  1558.     s_stdout->n_symvalue->n_fp = stdout;
  1559.     s_stdout->n_symvalue->n_savech = 0;
  1560.  
  1561.     /* enter the eval and apply hook variables */
  1562.     s_evalhook = xlsenter("*evalhook*");
  1563.     s_evalhook->n_symvalue = NIL;
  1564.     s_applyhook = xlsenter("*applyhook*");
  1565.     s_applyhook->n_symvalue = NIL;
  1566.  
  1567.     /* enter the error traceback and the error break enable flags */
  1568.     s_tracenable = xlsenter("*tracenable*");
  1569.     s_tracenable->n_symvalue = NIL;
  1570.     s_tlimit = xlsenter("*tracelimit*");
  1571.     s_tlimit->n_symvalue = NIL;
  1572.     s_breakenable = xlsenter("*breakenable*");
  1573.     s_breakenable->n_symvalue = true;
  1574.  
  1575.     /* enter a copyright notice into the oblist */
  1576.     sym = xlsenter("**Copyright-1985-by-David-Betz**");
  1577.     sym->n_symvalue = true;
  1578.  
  1579.     /* enter type names */
  1580.     a_subr    = xlsenter("SUBR");
  1581.     a_fsubr    = xlsenter("FSUBR");
  1582.     a_list    = xlsenter("LIST");
  1583.     a_sym    = xlsenter("SYM");
  1584.     a_int    = xlsenter("INT");
  1585.     a_str    = xlsenter("STR");
  1586.     a_obj    = xlsenter("OBJ");
  1587.     a_fptr    = xlsenter("FPTR");
  1588. }
  1589. SHAR_EOF
  1590. if test 3268 -ne "`wc -c < 'xlinit.c'`"
  1591. then
  1592.     echo shar: error transmitting "'xlinit.c'" '(should have been 3268 characters)'
  1593. fi
  1594. fi # end of overwriting check
  1595. echo shar: extracting "'xlio.c'" '(2897 characters)'
  1596. if test -f 'xlio.c'
  1597. then
  1598.     echo shar: will not over-write existing file "'xlio.c'"
  1599. else
  1600. sed 's/^X//' << \SHAR_EOF > 'xlio.c'
  1601. /* xlio - xlisp i/o routines */
  1602.  
  1603. #include "xlisp.h"
  1604.  
  1605. /* external variables */
  1606. extern int xlplevel;
  1607. extern int xlfsize;
  1608. extern NODE *xlstack;
  1609. extern NODE *s_stdin;
  1610. extern int xldebug;
  1611. extern int prompt;
  1612.  
  1613. /* xlgetc - get a character from a file or stream */
  1614. int xlgetc(fptr)
  1615.   NODE *fptr;
  1616. {
  1617.     NODE *lptr,*cptr;
  1618.     FILE *fp;
  1619.     int ch;
  1620.  
  1621.     /* check for input from nil */
  1622.     if (fptr == NIL)
  1623.     ch = EOF;
  1624.  
  1625.     /* otherwise, check for input from a stream */
  1626.     else if (consp(fptr)) {
  1627.     if ((lptr = car(fptr)) == NIL)
  1628.         ch = EOF;
  1629.     else {
  1630.         if (!consp(lptr) ||
  1631.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  1632.         xlfail("bad stream");
  1633.         if (rplaca(fptr,cdr(lptr)) == NIL)
  1634.         rplacd(fptr,NIL);
  1635.         ch = cptr->n_int;
  1636.     }
  1637.     }
  1638.  
  1639.     /* otherwise, check for a buffered file character */
  1640.     else if (ch = fptr->n_savech)
  1641.     fptr->n_savech = 0;
  1642.  
  1643.     /* otherwise, get a new character */
  1644.     else {
  1645.  
  1646.     /* get the file pointer */
  1647.     fp = fptr->n_fp;
  1648.  
  1649.     /* prompt if necessary */
  1650.     if (prompt && fp == stdin) {
  1651.  
  1652.         /* print the debug level */
  1653.         if (xldebug)
  1654.         printf("%d:",xldebug);
  1655.  
  1656.         /* print the nesting level */
  1657.         if (xlplevel > 0)
  1658.         printf("%d",xlplevel);
  1659.  
  1660.         /* print the prompt */
  1661.         printf("> ");
  1662.         prompt = FALSE;
  1663.     }
  1664.  
  1665.     /* get the character */
  1666.     if (((ch = getc(fp)) == '\n' || ch == EOF) && fp == stdin)
  1667.         prompt = TRUE;
  1668.  
  1669.     /* check for input abort */
  1670.     if (fp == stdin && ch == '\007') {
  1671.         putchar('\n');
  1672.         xlabort("input aborted");
  1673.     }
  1674.     }
  1675.  
  1676.     /* return the character */
  1677.     return (ch);
  1678. }
  1679.  
  1680. /* xlpeek - peek at a character from a file or stream */
  1681. int xlpeek(fptr)
  1682.   NODE *fptr;
  1683. {
  1684.     NODE *lptr,*cptr;
  1685.     int ch;
  1686.  
  1687.     /* check for input from nil */
  1688.     if (fptr == NIL)
  1689.     ch = EOF;
  1690.  
  1691.     /* otherwise, check for input from a stream */
  1692.     else if (consp(fptr)) {
  1693.     if ((lptr = car(fptr)) == NIL)
  1694.         ch = EOF;
  1695.     else {
  1696.         if (!consp(lptr) ||
  1697.         (cptr = car(lptr)) == NIL || !fixp(cptr))
  1698.         xlfail("bad stream");
  1699.         ch = cptr->n_int;
  1700.     }
  1701.     }
  1702.  
  1703.     /* otherwise, get the next file character and save it */
  1704.     else
  1705.     ch = fptr->n_savech = xlgetc(fptr);
  1706.  
  1707.     /* return the character */
  1708.     return (ch);
  1709. }
  1710.  
  1711. /* xlputc - put a character to a file or stream */
  1712. xlputc(fptr,ch)
  1713.   NODE *fptr; int ch;
  1714. {
  1715.     NODE *oldstk,lptr;
  1716.  
  1717.     /* count the character */
  1718.     xlfsize++;
  1719.  
  1720.     /* check for output to nil */
  1721.     if (fptr == NIL)
  1722.     ;
  1723.  
  1724.     /* otherwise, check for output to a stream */
  1725.     else if (consp(fptr)) {
  1726.     oldstk = xlsave(&lptr,NULL);
  1727.     lptr.n_ptr = newnode(LIST);
  1728.     rplaca(lptr.n_ptr,newnode(INT));
  1729.     car(lptr.n_ptr)->n_int = ch;
  1730.     if (cdr(fptr))
  1731.         rplacd(cdr(fptr),lptr.n_ptr);
  1732.     else
  1733.         rplaca(fptr,lptr.n_ptr);
  1734.     rplacd(fptr,lptr.n_ptr);
  1735.     xlstack = oldstk;
  1736.     }
  1737.  
  1738.     /* otherwise, output the character to a file */
  1739.     else
  1740.     putc(ch,fptr->n_fp);
  1741. }
  1742.  
  1743. /* xlflush - flush the input buffer */
  1744. int xlflush()
  1745. {
  1746.     if (!prompt)
  1747.     while (xlgetc(s_stdin->n_symvalue) != '\n')
  1748.         ;
  1749. }
  1750. SHAR_EOF
  1751. if test 2897 -ne "`wc -c < 'xlio.c'`"
  1752. then
  1753.     echo shar: error transmitting "'xlio.c'" '(should have been 2897 characters)'
  1754. fi
  1755. fi # end of overwriting check
  1756. echo shar: extracting "'xlisp.c'" '(1820 characters)'
  1757. if test -f 'xlisp.c'
  1758. then
  1759.     echo shar: will not over-write existing file "'xlisp.c'"
  1760. else
  1761. sed 's/^X//' << \SHAR_EOF > 'xlisp.c'
  1762. /* xlisp - an experimental version of lisp that supports object-oriented
  1763.            programming */
  1764.  
  1765. #include "xlisp.h"
  1766.  
  1767. /* define the banner line string */
  1768. #define BANNER    "XLISP version 1.4 - 14-FEB-1985, by David Betz"
  1769.  
  1770. /* external variables */
  1771. extern NODE *s_stdin,*s_stdout;
  1772. extern NODE *s_evalhook,*s_applyhook;
  1773. extern NODE *true;
  1774.  
  1775. /* main - the main routine */
  1776. main()
  1777. /*
  1778. main(argc,argv)
  1779.   int argc; char *argv[];
  1780. */
  1781. {
  1782.     NODE expr;
  1783.     CONTEXT cntxt;
  1784.     int i;
  1785.  
  1786.     /* print the banner line */
  1787. #ifdef MEGAMAX
  1788.     _autowin(BANNER);
  1789. #else
  1790.     printf("%s\n",BANNER);
  1791. #endif
  1792.  
  1793.     /* setup initialization error handler */
  1794.     xlbegin(&cntxt,CF_ERROR,(NODE *) 1);
  1795.     if (setjmp(cntxt.c_jmpbuf)) {
  1796.     printf("fatal initialization error\n");
  1797.     exit();
  1798.     }
  1799.  
  1800.     /* initialize xlisp */
  1801.     xlinit();
  1802.     xlend(&cntxt);
  1803.  
  1804.     /* reset the error handler */
  1805.     xlbegin(&cntxt,CF_ERROR,true);
  1806.  
  1807.     /* load "init.lsp" */
  1808.     if (setjmp(cntxt.c_jmpbuf) == 0)
  1809.     xlload("init",FALSE,FALSE);
  1810.  
  1811.     /* load any files mentioned on the command line */
  1812. /**
  1813.     if (setjmp(cntxt.c_jmpbuf) == 0)
  1814.     for (i = 1; i < argc; i++)
  1815.         if (!xlload(argv[i],TRUE,FALSE)) xlfail("can't load file");
  1816. **/
  1817.  
  1818.     /* create a new stack frame */
  1819.     xlsave(&expr,NULL);
  1820.  
  1821.     /* main command processing loop */
  1822.     while (TRUE) {
  1823.  
  1824.     /* setup the error return */
  1825.     if (setjmp(cntxt.c_jmpbuf)) {
  1826.         s_evalhook->n_symvalue = NIL;
  1827.         s_applyhook->n_symvalue = NIL;
  1828.         xlflush();
  1829.     }
  1830.  
  1831.     /* read an expression */
  1832.     if (!xlread(s_stdin->n_symvalue,&expr.n_ptr))
  1833.         break;
  1834.  
  1835.     /* evaluate the expression */
  1836.     expr.n_ptr = xleval(expr.n_ptr);
  1837.  
  1838.     /* print it */
  1839.     stdprint(expr.n_ptr);
  1840.     }
  1841.     xlend(&cntxt);
  1842. }
  1843.  
  1844. /* stdprint - print to standard output */
  1845. stdprint(expr)
  1846.   NODE *expr;
  1847. {
  1848.     xlprint(s_stdout->n_symvalue,expr,TRUE);
  1849.     xlterpri(s_stdout->n_symvalue);
  1850. }
  1851. SHAR_EOF
  1852. if test 1820 -ne "`wc -c < 'xlisp.c'`"
  1853. then
  1854.     echo shar: error transmitting "'xlisp.c'" '(should have been 1820 characters)'
  1855. fi
  1856. fi # end of overwriting check
  1857. echo shar: extracting "'xljump.c'" '(2300 characters)'
  1858. if test -f 'xljump.c'
  1859. then
  1860.     echo shar: will not over-write existing file "'xljump.c'"
  1861. else
  1862. sed 's/^X//' << \SHAR_EOF > 'xljump.c'
  1863. /* xljump - execution context routines */
  1864.  
  1865. #include "xlisp.h"
  1866.  
  1867. /* external variables */
  1868. extern CONTEXT *xlcontext;
  1869. extern NODE *xlvalue;
  1870. extern NODE *xlstack,*xlenv,*xlnewenv;
  1871. extern int xltrace,xldebug;
  1872.  
  1873. /* xlbegin - beginning of an execution context */
  1874. xlbegin(cptr,flags,expr)
  1875.   CONTEXT *cptr; int flags; NODE *expr;
  1876. {
  1877.     cptr->c_flags = flags;
  1878.     cptr->c_expr = expr;
  1879.     cptr->c_xlstack = xlstack;
  1880.     cptr->c_xlenv = xlenv;
  1881.     cptr->c_xlnewenv = xlnewenv;
  1882.     cptr->c_xltrace = xltrace;
  1883.     cptr->c_xlcontext = xlcontext;
  1884.     xlcontext = cptr;
  1885. }
  1886.  
  1887. /* xlend - end of an execution context */
  1888. xlend(cptr)
  1889.   CONTEXT *cptr;
  1890. {
  1891.     xlcontext = cptr->c_xlcontext;
  1892. }
  1893.  
  1894. /* xljump - jump to a saved execution context */
  1895. xljump(cptr,type,val)
  1896.   CONTEXT *cptr; int type; NODE *val;
  1897. {
  1898.     /* restore the state */
  1899.     xlvalue = val;
  1900.     xlstack = cptr->c_xlstack;
  1901.     xlunbind(cptr->c_xlenv);
  1902.     xlnewenv = cptr->c_xlnewenv;
  1903.     xltrace = cptr->c_xltrace;
  1904.  
  1905.     /* call the handler */
  1906.     longjmp(cptr->c_jmpbuf,type);
  1907. }
  1908.  
  1909. /* xlgo - go to a label */
  1910. xlgo(label)
  1911.   NODE *label;
  1912. {
  1913.     CONTEXT *cptr;
  1914.     NODE *p;
  1915.  
  1916.     /* find a tagbody context */
  1917.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1918.     if (cptr->c_flags & CF_GO)
  1919.         for (p = cptr->c_expr; consp(p); p = cdr(p))
  1920.         if (car(p) == label)
  1921.             xljump(cptr,CF_GO,p);
  1922.     xlfail("no target for go");
  1923. }
  1924.  
  1925. /* xlreturn - return from a block */
  1926. xlreturn(val)
  1927.   NODE *val;
  1928. {
  1929.     CONTEXT *cptr;
  1930.  
  1931.     /* find a block context */
  1932.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1933.     if (cptr->c_flags & CF_RETURN)
  1934.         xljump(cptr,CF_RETURN,val);
  1935.     xlfail("no target for return");
  1936. }
  1937.  
  1938. /* xlthrow - throw to a catch */
  1939. xlthrow(tag,val)
  1940.   NODE *tag,*val;
  1941. {
  1942.     CONTEXT *cptr;
  1943.  
  1944.     /* find a catch context */
  1945.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1946.     if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
  1947.         xljump(cptr,CF_THROW,val);
  1948.     xlfail("no target for throw");
  1949. }
  1950.  
  1951. /* xlsignal - signal an error */
  1952. xlsignal(emsg,arg)
  1953.   char *emsg; NODE *arg;
  1954. {
  1955.     CONTEXT *cptr;
  1956.  
  1957.     /* find an error catcher */
  1958.     for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
  1959.     if (cptr->c_flags & CF_ERROR) {
  1960.         if (cptr->c_expr)
  1961.         xlerrprint("error",NULL,emsg,arg);
  1962.         xljump(cptr,CF_ERROR,NIL);
  1963.     }
  1964.     xlfail("no target for error");
  1965. }
  1966. SHAR_EOF
  1967. if test 2300 -ne "`wc -c < 'xljump.c'`"
  1968. then
  1969.     echo shar: error transmitting "'xljump.c'" '(should have been 2300 characters)'
  1970. fi
  1971. fi # end of overwriting check
  1972. echo shar: extracting "'xlmath.c'" '(5921 characters)'
  1973. if test -f 'xlmath.c'
  1974. then
  1975.     echo shar: will not over-write existing file "'xlmath.c'"
  1976. else
  1977. sed 's/^X//' << \SHAR_EOF > 'xlmath.c'
  1978. /* xlmath - xlisp builtin arithmetic functions */
  1979.  
  1980. #include "xlisp.h"
  1981.  
  1982. /* external variables */
  1983. extern NODE *xlstack;
  1984. extern NODE *true;
  1985.  
  1986. /* forward declarations */
  1987. XFORWARD NODE *unary();
  1988. XFORWARD NODE *binary();
  1989. XFORWARD NODE *predicate();
  1990. XFORWARD NODE *compare();
  1991.  
  1992. /* xadd - builtin function for addition */
  1993. NODE *xadd(args)
  1994.   NODE *args;
  1995. {
  1996.     return (binary(args,'+'));
  1997. }
  1998.  
  1999. /* xsub - builtin function for subtraction */
  2000. NODE *xsub(args)
  2001.   NODE *args;
  2002. {
  2003.     return (binary(args,'-'));
  2004. }
  2005.  
  2006. /* xmul - builtin function for multiplication */
  2007. NODE *xmul(args)
  2008.   NODE *args;
  2009. {
  2010.     return (binary(args,'*'));
  2011. }
  2012.  
  2013. /* xdiv - builtin function for division */
  2014. NODE *xdiv(args)
  2015.   NODE *args;
  2016. {
  2017.     return (binary(args,'/'));
  2018. }
  2019.  
  2020. /* xrem - builtin function for remainder */
  2021. NODE *xrem(args)
  2022.   NODE *args;
  2023. {
  2024.     return (binary(args,'%'));
  2025. }
  2026.  
  2027. /* xmin - builtin function for minimum */
  2028. NODE *xmin(args)
  2029.   NODE *args;
  2030. {
  2031.     return (binary(args,'m'));
  2032. }
  2033.  
  2034. /* xmax - builtin function for maximum */
  2035. NODE *xmax(args)
  2036.   NODE *args;
  2037. {
  2038.     return (binary(args,'M'));
  2039. }
  2040.  
  2041. /* xbitand - builtin function for bitwise and */
  2042. NODE *xbitand(args)
  2043.   NODE *args;
  2044. {
  2045.     return (binary(args,'&'));
  2046. }
  2047.  
  2048. /* xbitior - builtin function for bitwise inclusive or */
  2049. NODE *xbitior(args)
  2050.   NODE *args;
  2051. {
  2052.     return (binary(args,'|'));
  2053. }
  2054.  
  2055. /* xbitxor - builtin function for bitwise exclusive or */
  2056. NODE *xbitxor(args)
  2057.   NODE *args;
  2058. {
  2059.     return (binary(args,'^'));
  2060. }
  2061.  
  2062. /* binary - handle binary operations */
  2063. LOCAL NODE *binary(args,fcn)
  2064.   NODE *args; int fcn;
  2065. {
  2066.     int ival,iarg;
  2067.     NODE *val;
  2068.  
  2069.     /* get the first argument */
  2070.     ival = xlmatch(INT,&args)->n_int;
  2071.  
  2072.     /* treat '-' with a single argument as a special case */
  2073.     if (fcn == '-' && args == NIL)
  2074.     ival = -ival;
  2075.  
  2076.     /* handle each remaining argument */
  2077.     while (args) {
  2078.  
  2079.     /* get the next argument */
  2080.     iarg = xlmatch(INT,&args)->n_int;
  2081.  
  2082.     /* accumulate the result value */
  2083.     switch (fcn) {
  2084.     case '+':    ival += iarg; break;
  2085.     case '-':    ival -= iarg; break;
  2086.     case '*':    ival *= iarg; break;
  2087.     case '/':    ival /= iarg; break;
  2088.     case '%':    ival %= iarg; break;
  2089.     case 'M':    if (iarg > ival) ival = iarg; break;
  2090.     case 'm':    if (iarg < ival) ival = iarg; break;
  2091.     case '&':    ival &= iarg; break;
  2092.     case '|':    ival |= iarg; break;
  2093.     case '^':    ival ^= iarg; break;
  2094.     }
  2095.     }
  2096.  
  2097.     /* initialize value */
  2098.     val = newnode(INT);
  2099.     val->n_int = ival;
  2100.  
  2101.     /* return the result value */
  2102.     return (val);
  2103. }
  2104.  
  2105. /* xbitnot - bitwise not */
  2106. NODE *xbitnot(args)
  2107.   NODE *args;
  2108. {
  2109.     return (unary(args,'~'));
  2110. }
  2111.  
  2112. /* xabs - builtin function for absolute value */
  2113. NODE *xabs(args)
  2114.   NODE *args;
  2115. {
  2116.     return (unary(args,'A'));
  2117. }
  2118.  
  2119. /* xadd1 - builtin function for adding one */
  2120. NODE *xadd1(args)
  2121.   NODE *args;
  2122. {
  2123.     return (unary(args,'+'));
  2124. }
  2125.  
  2126. /* xsub1 - builtin function for subtracting one */
  2127. NODE *xsub1(args)
  2128.   NODE *args;
  2129. {
  2130.     return (unary(args,'-'));
  2131. }
  2132.  
  2133. /* unary - handle unary operations */
  2134. LOCAL NODE *unary(args,fcn)
  2135.   NODE *args; int fcn;
  2136. {
  2137.     NODE *val;
  2138.     int ival;
  2139.  
  2140.     /* get the argument */
  2141.     ival = xlmatch(INT,&args)->n_int;
  2142.     xllastarg(args);
  2143.  
  2144.     /* compute the result */
  2145.     switch (fcn) {
  2146.     case '~':    ival = ~ival; break;
  2147.     case 'A':    if (ival < 0) ival = -ival; break;
  2148.     case '+':    ival++; break;
  2149.     case '-':    ival--; break;
  2150.     }
  2151.  
  2152.     /* convert the value  */
  2153.     val = newnode(INT);
  2154.     val->n_int = ival;
  2155.  
  2156.     /* return the result value */
  2157.     return (val);
  2158. }
  2159.  
  2160. /* xminusp - is this number negative? */
  2161. NODE *xminusp(args)
  2162.   NODE *args;
  2163. {
  2164.     return (predicate(args,'-'));
  2165. }
  2166.  
  2167. /* xzerop - is this number zero? */
  2168. NODE *xzerop(args)
  2169.   NODE *args;
  2170. {
  2171.     return (predicate(args,'Z'));
  2172. }
  2173.  
  2174. /* xplusp - is this number positive? */
  2175. NODE *xplusp(args)
  2176.   NODE *args;
  2177. {
  2178.     return (predicate(args,'+'));
  2179. }
  2180.  
  2181. /* xevenp - is this number even? */
  2182. NODE *xevenp(args)
  2183.   NODE *args;
  2184. {
  2185.     return (predicate(args,'E'));
  2186. }
  2187.  
  2188. /* xoddp - is this number odd? */
  2189. NODE *xoddp(args)
  2190.   NODE *args;
  2191. {
  2192.     return (predicate(args,'O'));
  2193. }
  2194.  
  2195. /* predicate - handle a predicate function */
  2196. LOCAL NODE *predicate(args,fcn)
  2197.   NODE *args; int fcn;
  2198. {
  2199.     NODE *val;
  2200.     int ival;
  2201.  
  2202.     /* get the argument */
  2203.     ival = xlmatch(INT,&args)->n_int;
  2204.     xllastarg(args);
  2205.  
  2206.     /* compute the result */
  2207.     switch (fcn) {
  2208.     case '-':    ival = (ival < 0); break;
  2209.     case 'Z':    ival = (ival == 0); break;
  2210.     case '+':    ival = (ival > 0); break;
  2211.     case 'E':    ival = ((ival & 1) == 0); break;
  2212.     case 'O':    ival = ((ival & 1) != 0); break;
  2213.     }
  2214.  
  2215.     /* return the result value */
  2216.     return (ival ? true : NIL);
  2217. }
  2218.  
  2219. /* xlss - builtin function for < */
  2220. NODE *xlss(args)
  2221.   NODE *args;
  2222. {
  2223.     return (compare(args,'<'));
  2224. }
  2225.  
  2226. /* xleq - builtin function for <= */
  2227. NODE *xleq(args)
  2228.   NODE *args;
  2229. {
  2230.     return (compare(args,'L'));
  2231. }
  2232.  
  2233. /* equ - builtin function for = */
  2234. NODE *xequ(args)
  2235.   NODE *args;
  2236. {
  2237.     return (compare(args,'='));
  2238. }
  2239.  
  2240. /* xneq - builtin function for /= */
  2241. NODE *xneq(args)
  2242.   NODE *args;
  2243. {
  2244.     return (compare(args,'#'));
  2245. }
  2246.  
  2247. /* xgeq - builtin function for >= */
  2248. NODE *xgeq(args)
  2249.   NODE *args;
  2250. {
  2251.     return (compare(args,'G'));
  2252. }
  2253.  
  2254. /* xgtr - builtin function for > */
  2255. NODE *xgtr(args)
  2256.   NODE *args;
  2257. {
  2258.     return (compare(args,'>'));
  2259. }
  2260.  
  2261. /* compare - common compare function */
  2262. LOCAL NODE *compare(args,fcn)
  2263.   NODE *args; int fcn;
  2264. {
  2265.     NODE *arg1,*arg2;
  2266.     int cmp;
  2267.  
  2268.     /* get the two arguments */
  2269.     arg1 = xlarg(&args);
  2270.     arg2 = xlarg(&args);
  2271.     xllastarg(args);
  2272.  
  2273.     /* do the compare */
  2274.     if (stringp(arg1) && stringp(arg2))
  2275.     cmp = strcmp(arg1->n_str,arg2->n_str);
  2276.     else if (fixp(arg1) && fixp(arg2))
  2277.     cmp = arg1->n_int - arg2->n_int;
  2278.     else
  2279.     cmp = (int)(arg1 - arg2);
  2280.  
  2281.     /* compute result of the compare */
  2282.     switch (fcn) {
  2283.     case '<':    cmp = (cmp < 0); break;
  2284.     case 'L':    cmp = (cmp <= 0); break;
  2285.     case '=':    cmp = (cmp == 0); break;
  2286.     case '#':    cmp = (cmp != 0); break;
  2287.     case 'G':    cmp = (cmp >= 0); break;
  2288.     case '>':    cmp = (cmp > 0); break;
  2289.     }
  2290.  
  2291.     /* return the result */
  2292.     return (cmp ? true : NIL);
  2293. }
  2294. SHAR_EOF
  2295. if test 5921 -ne "`wc -c < 'xlmath.c'`"
  2296. then
  2297.     echo shar: error transmitting "'xlmath.c'" '(should have been 5921 characters)'
  2298. fi
  2299. fi # end of overwriting check
  2300. echo shar: extracting "'xlprin.c'" '(2789 characters)'
  2301. if test -f 'xlprin.c'
  2302. then
  2303.     echo shar: will not over-write existing file "'xlprin.c'"
  2304. else
  2305. sed 's/^X//' << \SHAR_EOF > 'xlprin.c'
  2306. /* xlprint - xlisp print routine */
  2307.  
  2308. #include "xlisp.h"
  2309.  
  2310. /* external variables */
  2311. extern NODE *xlstack;
  2312. extern char buf[];
  2313.  
  2314. /* xlprint - print an xlisp value */
  2315. xlprint(fptr,vptr,flag)
  2316.   NODE *fptr,*vptr; int flag;
  2317. {
  2318.     NODE *nptr,*next;
  2319.  
  2320.     /* print nil */
  2321.     if (vptr == NIL) {
  2322.     putstr(fptr,"nil");
  2323.     return;
  2324.     }
  2325.  
  2326.     /* check value type */
  2327.     switch (ntype(vptr)) {
  2328.     case SUBR:
  2329.         putatm(fptr,"Subr",vptr);
  2330.         break;
  2331.     case FSUBR:
  2332.         putatm(fptr,"FSubr",vptr);
  2333.         break;
  2334.     case LIST:
  2335.         xlputc(fptr,'(');
  2336.         for (nptr = vptr; nptr != NIL; nptr = next) {
  2337.             xlprint(fptr,car(nptr),flag);
  2338.         if (next = cdr(nptr))
  2339.             if (consp(next))
  2340.             xlputc(fptr,' ');
  2341.             else {
  2342.             putstr(fptr," . ");
  2343.             xlprint(fptr,next,flag);
  2344.             break;
  2345.             }
  2346.         }
  2347.         xlputc(fptr,')');
  2348.         break;
  2349.     case SYM:
  2350.         putstr(fptr,xlsymname(vptr));
  2351.         break;
  2352.     case INT:
  2353.         putdec(fptr,vptr->n_int);
  2354.         break;
  2355.     case STR:
  2356.         if (flag)
  2357.         putstring(fptr,vptr->n_str);
  2358.         else
  2359.         putstr(fptr,vptr->n_str);
  2360.         break;
  2361.     case FPTR:
  2362.         putatm(fptr,"File",vptr);
  2363.         break;
  2364.     case OBJ:
  2365.         putatm(fptr,"Object",vptr);
  2366.         break;
  2367.     case FREE:
  2368.         putatm(fptr,"Free",vptr);
  2369.         break;
  2370.     default:
  2371.         putatm(fptr,"Foo",vptr);
  2372.         break;
  2373.     }
  2374. }
  2375.  
  2376. /* xlterpri - terminate the current print line */
  2377. xlterpri(fptr)
  2378.   NODE *fptr;
  2379. {
  2380.     xlputc(fptr,'\n');
  2381. }
  2382.  
  2383. /* putstring - output a string */
  2384. LOCAL putstring(fptr,str)
  2385.   NODE *fptr; char *str;
  2386. {
  2387.     int ch;
  2388.  
  2389.     /* output the initial quote */
  2390.     xlputc(fptr,'"');
  2391.  
  2392.     /* output each character in the string */
  2393.     while (ch = *str++)
  2394.  
  2395.     /* check for a control character */
  2396.     if (ch < 040 || ch == '\\') {
  2397.         xlputc(fptr,'\\');
  2398.         switch (ch) {
  2399.         case '\033':
  2400.             xlputc(fptr,'e');
  2401.             break;
  2402.         case '\n':
  2403.             xlputc(fptr,'n');
  2404.             break;
  2405.         case '\r':
  2406.             xlputc(fptr,'r');
  2407.             break;
  2408.         case '\t':
  2409.             xlputc(fptr,'t');
  2410.             break;
  2411.         case '\\':
  2412.             xlputc(fptr,'\\');
  2413.             break;
  2414.         default:
  2415.             putoct(fptr,ch);
  2416.             break;
  2417.         }
  2418.     }
  2419.  
  2420.     /* output a normal character */
  2421.     else
  2422.         xlputc(fptr,ch);
  2423.  
  2424.     /* output the terminating quote */
  2425.     xlputc(fptr,'"');
  2426. }
  2427.  
  2428. /* putatm - output an atom */
  2429. LOCAL putatm(fptr,tag,val)
  2430.   NODE *fptr; char *tag; NODE *val;
  2431. {
  2432.     sprintf(buf,"#<%s: #",tag); putstr(fptr,buf);
  2433.     sprintf(buf,AFMT,val); putstr(fptr,buf);
  2434.     xlputc(fptr,'>');
  2435. }
  2436.  
  2437. /* putdec - output a decimal number */
  2438. LOCAL putdec(fptr,n)
  2439.   NODE *fptr; int n;
  2440. {
  2441.     sprintf(buf,"%d",n);
  2442.     putstr(fptr,buf);
  2443. }
  2444.  
  2445. /* putoct - output an octal byte value */
  2446. LOCAL putoct(fptr,n)
  2447.   NODE *fptr; int n;
  2448. {
  2449.     sprintf(buf,"%03o",n);
  2450.     putstr(fptr,buf);
  2451. }
  2452.  
  2453. /* putstr - output a string */
  2454. LOCAL putstr(fptr,str)
  2455.   NODE *fptr; char *str;
  2456. {
  2457.     while (*str)
  2458.     xlputc(fptr,*str++);
  2459. }
  2460. SHAR_EOF
  2461. if test 2789 -ne "`wc -c < 'xlprin.c'`"
  2462. then
  2463.     echo shar: error transmitting "'xlprin.c'" '(should have been 2789 characters)'
  2464. fi
  2465. fi # end of overwriting check
  2466. echo shar: extracting "'xlread.c'" '(8381 characters)'
  2467. if test -f 'xlread.c'
  2468. then
  2469.     echo shar: will not over-write existing file "'xlread.c'"
  2470. else
  2471. sed 's/^X//' << \SHAR_EOF > 'xlread.c'
  2472. /* xlread - xlisp expression input routine */
  2473.  
  2474. #include "xlisp.h"
  2475. #include "ctype.h"
  2476.  
  2477. /* external variables */
  2478. extern NODE *s_stdout,*true;
  2479. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  2480. extern NODE *xlstack;
  2481. extern int xlplevel;
  2482.  
  2483. /* external routines */
  2484. extern FILE *fopen();
  2485.  
  2486. /* forward declarations */
  2487. XFORWARD NODE *plist();
  2488. XFORWARD NODE *pstring();
  2489. XFORWARD NODE *pquote();
  2490. XFORWARD NODE *pname();
  2491.  
  2492. /* xlload - load a file of xlisp expressions */
  2493. int xlload(name,vflag,pflag)
  2494.   char *name; int vflag,pflag;
  2495. {
  2496.     NODE *oldstk,fptr,expr;
  2497.     char fname[50];
  2498.     CONTEXT cntxt;
  2499.     int sts;
  2500.  
  2501.     /* create a new stack frame */
  2502.     oldstk = xlsave(&fptr,&expr,NULL);
  2503.  
  2504.     /* allocate a file node */
  2505.     fptr.n_ptr = newnode(FPTR);
  2506.     fptr.n_ptr->n_fp = NULL;
  2507.     fptr.n_ptr->n_savech = 0;
  2508.  
  2509.     /* create the file name and print the information line */
  2510.     strcpy(fname,name); strcat(fname,".lsp");
  2511.     if (vflag)
  2512.     printf("; loading \"%s\"\n",fname);
  2513.  
  2514.     /* open the file */
  2515.     if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
  2516.     xlstack = oldstk;
  2517.     return (FALSE);
  2518.     }
  2519.  
  2520.     /* read, evaluate and possibly print each expression in the file */
  2521.     xlbegin(&cntxt,CF_ERROR,true);
  2522.     if (setjmp(cntxt.c_jmpbuf))
  2523.     sts = FALSE;
  2524.     else {
  2525.     while (xlread(fptr.n_ptr,&expr.n_ptr)) {
  2526.         expr.n_ptr = xleval(expr.n_ptr);
  2527.         if (pflag)
  2528.         stdprint(expr.n_ptr);
  2529.     }
  2530.     sts = TRUE;
  2531.     }
  2532.     xlend(&cntxt);
  2533.  
  2534.     /* close the file */
  2535.     fclose(fptr.n_ptr->n_fp);
  2536.     fptr.n_ptr->n_fp = NULL;
  2537.  
  2538.     /* restore the previous stack frame */
  2539.     xlstack = oldstk;
  2540.  
  2541.     /* return status */
  2542.     return (sts);
  2543. }
  2544.  
  2545. /* xlread - read an xlisp expression */
  2546. int xlread(fptr,pval)
  2547.   NODE *fptr,**pval;
  2548. {
  2549.     /* initialize */
  2550.     xlplevel = 0;
  2551.  
  2552.     /* parse an expression */
  2553.     return (parse(fptr,pval));
  2554. }
  2555.  
  2556. /* parse - parse an xlisp expression */
  2557. LOCAL int parse(fptr,pval)
  2558.   NODE *fptr,**pval;
  2559. {
  2560.     int ch;
  2561.  
  2562.     /* keep looking for a node skipping comments */
  2563.     while (TRUE)
  2564.  
  2565.     /* check next character for type of node */
  2566.     switch (ch = nextch(fptr)) {
  2567.     case EOF:
  2568.         xlgetc(fptr);
  2569.         return (FALSE);
  2570.     case '\'':            /* a quoted expression */
  2571.         xlgetc(fptr);
  2572.         *pval = pquote(fptr,s_quote);
  2573.         return (TRUE);
  2574.     case '#':            /* a quoted function */
  2575.         xlgetc(fptr);
  2576.         if ((ch = xlgetc(fptr)) == '<')
  2577.             xlfail("unreadable atom");
  2578.         else if (ch != '\'')
  2579.             xlfail("expected quote after #");
  2580.         *pval = pquote(fptr,s_function);
  2581.         return (TRUE);
  2582.     case '`':            /* a back quoted expression */
  2583.         xlgetc(fptr);
  2584.         *pval = pquote(fptr,s_bquote);
  2585.         return (TRUE);
  2586.     case ',':            /* a comma or comma-at expression */
  2587.         xlgetc(fptr);
  2588.         if (xlpeek(fptr) == '@') {
  2589.             xlgetc(fptr);
  2590.             *pval = pquote(fptr,s_comat);
  2591.         }
  2592.         else
  2593.             *pval = pquote(fptr,s_comma);
  2594.         return (TRUE);
  2595.     case '(':            /* a sublist */
  2596.         *pval = plist(fptr);
  2597.         return (TRUE);
  2598.     case ')':            /* closing paren - shouldn't happen */
  2599.         xlfail("extra right paren");
  2600.     case '.':            /* dot - shouldn't happen */
  2601.         xlfail("misplaced dot");
  2602.     case ';':            /* a comment */
  2603.         pcomment(fptr);
  2604.         break;
  2605.     case '"':            /* a string */
  2606.         *pval = pstring(fptr);
  2607.         return (TRUE);
  2608.     default:
  2609.         if (issym(ch))        /* a name */
  2610.             *pval = pname(fptr);
  2611.         else
  2612.             xlfail("invalid character");
  2613.         return (TRUE);
  2614.     }
  2615. }
  2616.  
  2617. /* pcomment - parse a comment */
  2618. LOCAL pcomment(fptr)
  2619.   NODE *fptr;
  2620. {
  2621.     int ch;
  2622.  
  2623.     /* skip to end of line */
  2624.     while ((ch = checkeof(fptr)) != EOF && ch != '\n')
  2625.     ;
  2626. }
  2627.  
  2628. /* plist - parse a list */
  2629. LOCAL NODE *plist(fptr)
  2630.   NODE *fptr;
  2631. {
  2632.     NODE *oldstk,val,*lastnptr,*nptr,*p;
  2633.     int ch;
  2634.  
  2635.     /* increment the nesting level */
  2636.     xlplevel += 1;
  2637.  
  2638.     /* create a new stack frame */
  2639.     oldstk = xlsave(&val,NULL);
  2640.  
  2641.     /* skip the opening paren */
  2642.     xlgetc(fptr);
  2643.  
  2644.     /* keep appending nodes until a closing paren is found */
  2645.     lastnptr = NIL;
  2646.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  2647.  
  2648.     /* check for end of file */
  2649.     if (ch == EOF)
  2650.         badeof(fptr);
  2651.  
  2652.     /* check for a dotted pair */
  2653.     if (ch == '.') {
  2654.  
  2655.         /* skip the dot */
  2656.         xlgetc(fptr);
  2657.  
  2658.         /* make sure there's a node */
  2659.         if (lastnptr == NIL)
  2660.         xlfail("invalid dotted pair");
  2661.  
  2662.         /* parse the expression after the dot */
  2663.         if (!parse(fptr,&p))
  2664.         badeof(fptr);
  2665.         rplacd(lastnptr,p);
  2666.  
  2667.         /* make sure its followed by a close paren */
  2668.         if (nextch(fptr) != ')')
  2669.         xlfail("invalid dotted pair");
  2670.  
  2671.         /* done with this list */
  2672.         break;
  2673.     }
  2674.  
  2675.     /* allocate a new node and link it into the list */
  2676.     nptr = newnode(LIST);
  2677.     if (lastnptr == NIL)
  2678.         val.n_ptr = nptr;
  2679.     else
  2680.         rplacd(lastnptr,nptr);
  2681.  
  2682.     /* initialize the new node */
  2683.     if (!parse(fptr,&p))
  2684.         badeof(fptr);
  2685.     rplaca(nptr,p);
  2686.     }
  2687.  
  2688.     /* skip the closing paren */
  2689.     xlgetc(fptr);
  2690.  
  2691.     /* restore the previous stack frame */
  2692.     xlstack = oldstk;
  2693.  
  2694.     /* decrement the nesting level */
  2695.     xlplevel -= 1;
  2696.  
  2697.     /* return successfully */
  2698.     return (val.n_ptr);
  2699. }
  2700.  
  2701. /* pstring - parse a string */
  2702. LOCAL NODE *pstring(fptr)
  2703.   NODE *fptr;
  2704. {
  2705.     NODE *oldstk,val;
  2706.     char sbuf[STRMAX+1];
  2707.     int ch,i,d1,d2,d3;
  2708.  
  2709.     /* create a new stack frame */
  2710.     oldstk = xlsave(&val,NULL);
  2711.  
  2712.     /* skip the opening quote */
  2713.     xlgetc(fptr);
  2714.  
  2715.     /* loop looking for a closing quote */
  2716.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  2717.     switch (ch) {
  2718.     case EOF:
  2719.         badeof(fptr);
  2720.     case '\\':
  2721.         switch (ch = checkeof(fptr)) {
  2722.         case 'e':
  2723.             ch = '\033';
  2724.             break;
  2725.         case 'n':
  2726.             ch = '\n';
  2727.             break;
  2728.         case 'r':
  2729.             ch = '\r';
  2730.             break;
  2731.         case 't':
  2732.             ch = '\t';
  2733.             break;
  2734.         default:
  2735.             if (ch >= '0' && ch <= '7') {
  2736.                 d1 = ch - '0';
  2737.                 d2 = checkeof(fptr) - '0';
  2738.                 d3 = checkeof(fptr) - '0';
  2739.                 ch = (d1 << 6) + (d2 << 3) + d3;
  2740.             }
  2741.             break;
  2742.         }
  2743.     }
  2744.     sbuf[i] = ch;
  2745.     }
  2746.     sbuf[i] = 0;
  2747.  
  2748.     /* initialize the node */
  2749.     val.n_ptr = newnode(STR);
  2750.     val.n_ptr->n_str = strsave(sbuf);
  2751.     val.n_ptr->n_strtype = DYNAMIC;
  2752.  
  2753.     /* restore the previous stack frame */
  2754.     xlstack = oldstk;
  2755.  
  2756.     /* return the new string */
  2757.     return (val.n_ptr);
  2758. }
  2759.  
  2760. /* pquote - parse a quoted expression */
  2761. LOCAL NODE *pquote(fptr,sym)
  2762.   NODE *fptr,*sym;
  2763. {
  2764.     NODE *oldstk,val,*p;
  2765.  
  2766.     /* create a new stack frame */
  2767.     oldstk = xlsave(&val,NULL);
  2768.  
  2769.     /* allocate two nodes */
  2770.     val.n_ptr = newnode(LIST);
  2771.     rplaca(val.n_ptr,sym);
  2772.     rplacd(val.n_ptr,newnode(LIST));
  2773.  
  2774.     /* initialize the second to point to the quoted expression */
  2775.     if (!parse(fptr,&p))
  2776.     badeof(fptr);
  2777.     rplaca(cdr(val.n_ptr),p);
  2778.  
  2779.     /* restore the previous stack frame */
  2780.     xlstack = oldstk;
  2781.  
  2782.     /* return the quoted expression */
  2783.     return (val.n_ptr);
  2784. }
  2785.  
  2786. /* pname - parse a symbol name */
  2787. LOCAL NODE *pname(fptr)
  2788.   NODE *fptr;
  2789. {
  2790.     char sname[STRMAX+1];
  2791.     NODE *val;
  2792.     int i;
  2793.  
  2794.     /* get symbol name */
  2795.     for (i = 0; i < STRMAX && issym(xlpeek(fptr)); )
  2796.     sname[i++] = xlgetc(fptr);
  2797.     sname[i] = 0;
  2798.  
  2799.     /* check for a number or enter the symbol into the oblist */
  2800.     return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
  2801. }
  2802.  
  2803. /* nextch - look at the next non-blank character */
  2804. LOCAL int nextch(fptr)
  2805.   NODE *fptr;
  2806. {
  2807.     int ch;
  2808.  
  2809.     /* return and save the next non-blank character */
  2810.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  2811.     xlgetc(fptr);
  2812.     return (ch);
  2813. }
  2814.  
  2815. /* checkeof - get a character and check for end of file */
  2816. LOCAL int checkeof(fptr)
  2817.   NODE *fptr;
  2818. {
  2819.     int ch;
  2820.  
  2821.     if ((ch = xlgetc(fptr)) == EOF)
  2822.     badeof(fptr);
  2823.     return (ch);
  2824. }
  2825.  
  2826. /* badeof - unexpected eof */
  2827. LOCAL badeof(fptr)
  2828.   NODE *fptr;
  2829. {
  2830.     xlgetc(fptr);
  2831.     xlfail("unexpected EOF");
  2832. }
  2833.  
  2834. /* isnumber - check if this string is a number */
  2835. int isnumber(str,pval)
  2836.   char *str; NODE **pval;
  2837. {
  2838.     char *p;
  2839.     int d;
  2840.  
  2841.     /* initialize */
  2842.     p = str; d = 0;
  2843.  
  2844.     /* check for a sign */
  2845.     if (*p == '+' || *p == '-')
  2846.     p++;
  2847.  
  2848.     /* check for a string of digits */
  2849.     while (isdigit(*p))
  2850.     p++, d++;
  2851.  
  2852.     /* make sure there was at least one digit and this is the end */
  2853.     if (d == 0 || *p)
  2854.     return (FALSE);
  2855.  
  2856.     /* convert the string to an integer and return successfully */
  2857.     *pval = newnode(INT);
  2858.     (*pval)->n_int = atoi(*str == '+' ? ++str : str);
  2859.     return (TRUE);
  2860. }
  2861.  
  2862. /* issym - check whether a character if valid in a symbol name */
  2863. LOCAL int issym(ch)
  2864.   int ch;
  2865. {
  2866.     if (ch <= ' ' || ch >= 0177 ||
  2867.         ch == '(' ||
  2868.         ch == ')' ||
  2869.         ch == ';' || 
  2870.     ch == ',' ||
  2871.     ch == '`' ||
  2872.         ch == '"' ||
  2873.         ch == '\'')
  2874.     return (FALSE);
  2875.     else
  2876.     return (TRUE);
  2877. }
  2878. SHAR_EOF
  2879. if test 8381 -ne "`wc -c < 'xlread.c'`"
  2880. then
  2881.     echo shar: error transmitting "'xlread.c'" '(should have been 8381 characters)'
  2882. fi
  2883. fi # end of overwriting check
  2884. #    End of shell archive
  2885. exit 0
  2886.  
  2887.